!IPK LAST UPDATE SEP 23 2015 REVISE org NUMBERS SUBROUTINE get_label(dlin,title) use winteracter implicit none include 'd.inc' ! ! Declare window-type and message variables ! TYPE(WIN_STYLE) :: WINDOW TYPE(WIN_MESSAGE) :: MESSAGE INTEGER :: ITYPE,ierr character*40 dlin,title write(90,'(a)') 'dlin',dlin write(90,'(a)') 'lind',title call wdialogload(IDD_DIALOG1) ierr=infoerror(1) write(90,'(a)') 'dlin-0',dlin write(90,'(a)') 'lind-0',title CALL WDialogPutString(idf_label5,dlin) ierr=infoerror(1) CALL WDialogSelect(IDD_DIALOG1) ierr=infoerror(1) CALL WDialogShow(-1,-1,0,Modal) ierr=infoerror(1) do !! CALL WMessage(ITYPE,MESSAGE) ! ! Branch depending on type of message. ! IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN call wdialoggetstring(idf_string24,title) write(90,'(a)') 'dlin-1',dlin write(90,'(a)') 'lind-1',title return endif return enddo return end ! ---------------------------------------------------------------------------- subroutine labl(x,y,llen,ht,string) USE WINTERACTER character*(*) string integer llen character*80 outstring data rsclx,rscly/100.,100./ DO i=1,llen outstring(i:i)=string(i:i) ENDDO ix=x*rsclx iy=y*rscly CALL gim_a_string(ix,iy,ht,outstring,llen) RETURN end SUBROUTINE gim_a_string(ix,iy,ht,outstring,lenth) USE WINTERACTER CHARACTER*(*) OUTSTRING CALL WGrTextFont(102,0,ht*0.0133333,ht*0.04) ! CALL IGrCharSet(' ') ! CALL IGrCharSize(ht,ht) call WGrTextOrientation(0) ! CALL IGrCharJustify('L') x=ix/100. y=iy/100. CALL WGrTextString(x,y,outstring(:lenth)) ! CALL IGrCharOut(x,y,outstring(:lenth)) RETURN END SUBROUTINE SUBROUTINE change_color(icl) USE WINTERACTER DIMENSION ICOLRS(0:16) data icolrs/224,0,160,175,159,112,128,96,80,& 48,63,24,16,47,223,7,224/ ! 240 ICV=ICOLRS(mod(ICL,16)) CALL IGrcolourN(ICV) RETURN END SUBROUTINE SUBROUTINE fill_a_polygon(x,y,npts) USE WINTERACTER dimension x(*),y(*) CALL IGrFillPattern(4,0,0) call IGrPolygonComplex(x,y,npts) RETURN END SUBROUTINE SUBROUTINE gim_a_charac(key,cha,x,y) USE WINTERACTER CHARACTER*(*) cha INTEGER :: ITYPE, KEY INTEGER, PARAMETER :: ID_EXIT = 40002 TYPE(WIN_MESSAGE) :: MESSAGE 100 CONTINUE CALL WMessage(ITYPE, MESSAGE) SELECT CASE (ITYPE) CASE (KeyDown) ! Key pressed KEY = MESSAGE%VALUE1 MOUSEX = MESSAGE%X MOUSEY = MESSAGE%Y ! check key status if(KEY .lt. 127) then cha=char(KEY) go to 250 else go to 100 endif CASE (MenuSelect) ! Menu item selected SELECT CASE (MESSAGE%VALUE1) CASE (ID_EXIT) call WindowClose END SELECT END SELECT GO TO 100 250 CONTINUE RETURN END SUBROUTINE SUBROUTINE clear_screen USE WINTERACTER INCLUDE 'TXFRM.COM' TYPE (WIN_FONT) :: FONT ! FONT%IBCOL = TextWhite ! CALL WindowFont(FONT) ! IRGB = WRGB(220,220,220) CALL WindowClear(rgb=irgb) ! clear to yellow RETURN END SUBROUTINE SUBROUTINE gim_a_line(ix,iy) USE WINTERACTER x=ix/100. y=iy/100. CALL IGrLineto(x,y) RETURN END SUBROUTINE SUBROUTINE move_da_pointer(ix, iy) USE WINTERACTER x=ix/100. y=iy/100. CALL IGrMoveto(x,y) RETURN END SUBROUTINE SUBROUTINE clear_box USE WINTERACTER REAL HSIZE COMMON /SSIZE/ HSIZE dimension x(4),y(4) x(1)=0. x(2)=HSIZE x(3)=HSIZE x(4)=0. y(1)=7.50 y(2)=7.50 y(3)=8.0 y(4)=8.0 call Rwhite call IGrColourN(48) CALL IGrFillPattern(4,0,0) call IGrPolygonComplex(x,y,4) call RBlue return END SUBROUTINE SUBROUTINE get_rid_window USE WINTERACTER call WindowClose RETURN END SUBROUTINE SUBROUTINE flush_screen RETURN END SUBROUTINE SUBROUTINE RMINFO use winteracter implicit none include 'd.inc' CHARACTER(LEN=255) :: FNAME CHARACTER(LEN=3) :: SUB LOGICAL :: OPENED INTEGER :: IERR ! ! Declare window-type and message variables ! TYPE(WIN_STYLE) :: WINDOW TYPE(WIN_MESSAGE) :: MESSAGE call wdialogload(IDD_DIALOG09) ierr=infoerror(1) CALL WDialogSelect(IDD_DIALOG09) ierr=infoerror(1) CALL WDialogShow(-1,-1,0,Modal) ierr=infoerror(1) do IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN return endif return enddo RETURN END SUBROUTINE SUBROUTINE GETMDIS(nmapf,nsigf,icolsw,rad,colint) use winteracter implicit none include 'd.inc' CHARACTER(LEN=255) :: FNAME CHARACTER(LEN=3) :: SUB LOGICAL :: OPENED INTEGER :: IERR,NMAPF,NSIGF,icolsw REAL :: RAD,COLINT ! ! Declare window-type and message variables ! TYPE(WIN_STYLE) :: WINDOW TYPE(WIN_MESSAGE) :: MESSAGE call wdialogload(IDD_DIALOG10) ierr=infoerror(1) CALL WDialogSelect(IDD_DIALOG10) ierr=infoerror(1) CALL WDialogPutINTEGER(IDF_INTEGER1,nsigf) CALL WDialogPutINTEGER(IDF_INTEGER2,nmapf) CALL WDialogPutReal(IDF_REAL1,rad) CALL WDialogPutReal(IDF_REAL2,colint) call wdialogputcheckbox(idf_check1,icolsw) CALL WDialogShow(-1,-1,0,Modal) ierr=infoerror(1) do IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN CALL WDialogGetINTEGER(IDF_INTEGER1,nsigf) CALL WDialogGetINTEGER(IDF_INTEGER2,nmapf) call wdialogGetcheckbox(idf_check1,icolsw) CALL WDialogGetReal(IDF_REAL1,rad) CALL WDialogGetReal(IDF_REAL2,colint) return endif return enddo RETURN END SUBROUTINE SUBROUTINE THICKL CALL IGrLineWidth(2,2,2) RETURN END SUBROUTINE THINL CALL IGrLineWidth(1,1,1) RETURN END SUBROUTINE OUTORG(FNAME) CHARACTER(LEN=255) :: FNAME INCLUDE 'TXFRM.COM' REAL HSIZE COMMON /SSIZE/ HSIZE !IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL OPEN(104,FILE=FNAME,STATUS ='UNKNOWN', FORM ='FORMATTED') !!! WRITE(104,'(4G16.8)') -XS,-YS,HSIZE*TXSCAL-XS,7.5*TXSCAL-YS WRITE(104,'(4G16.8)') -XS,-YS,HSIZE*TXSCAL-XS,8.0*TXSCAL-YS CLOSE(104) RETURN END SUBROUTINE DRAWBK(I,IMZ) INCLUDE 'TXFRM.COM' !IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL INCLUDE 'BFILES.I90' REAL HSIZE COMMON /SSIZE/ HSIZE IF(IMZ .EQ. -1) THEN VRANGE=7.5 ELSE VRANGE=8.0 ENDIF XBKMN=((BFMINMAX(I,1)+XS)/TXSCAL)/HSIZE XBKMX=((BFMINMAX(I,3)+XS)/TXSCAL)/HSIZE YBKMN=((BFMINMAX(I,2)+YS)/TXSCAL)/VRANGE YBKMX=((BFMINMAX(I,4)+YS)/TXSCAL)/VRANGE ! WRITE(90,*) 'BACKGND',XBKMN,XBKMX,YBKMN,YHSIZEBKMX IF(XBKMN .GT. 1.) RETURN IF(XBKMX .LT. 0.) RETURN IF(YBKMN .GT. 1.) RETURN IF(YBKMX .LT. 0.) RETURN XRANGE=XBKMX-XBKMN YRANGE=YBKMX-YBKMN IF(XBKMX .GT. 1.) THEN XGRMX=(1.-XBKMN)/XRANGE XBKMX=1.0 ELSE XGRMX=1. ENDIF IF(XBKMN .LT. 0.) THEN XGRMN=-XBKMN/XRANGE XBKMN=0. ELSE XGRMN=0. ENDIF IF(YBKMX .GT. 1.) THEN YGRMX=(1.-YBKMN)/YRANGE YBKMX=1.0 ELSE YGRMX=1. ENDIF IF(YBKMN .LT. 0.) THEN YGRMN=-YBKMN/YRANGE YBKMN=0. ELSE YGRMN=0. ENDIF ! WRITE(90,*) 'BACKGN2',XBKMN,XBKMX,YBKMN,YBKMX ! WRITE(90,*) 'XGR ',XGRMN,YGRMN,XGRMX,YGRMX CALL IGrArea(XBKMN,YBKMN,XBKMX,YBKMX) CALL IGrReplayArea(XGRMN,YGRMN,XGRMX,YGRMX) call IGrReplay(BFNAME(I)) CALL IGrArea(0.0,0.0,1.0,1.0) RETURN END SUBROUTINE DRAWBKBM(I,IMZ) USE WINTERACTER REAL HSIZE COMMON /SSIZE/ HSIZE CHARACTER*1 IFLAG INTEGER, DIMENSION(6) :: INFO INCLUDE 'TXFRM.COM' !IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL INCLUDE 'BFILES.I90' ! DATA IHAND1,IHAND2/0,0/ INTEGER :: iw,ih,ihandle,ient,IHAND1,IHAND2,IXPM,IYPX,IXPX,IYPM common /hands/ iw,ih,ihandle,IHAND1,IHAND2,IXPM,IYPX,IXPX,IYPM XBKMN=((BFMINMAX(I,1)+XS)/TXSCAL) XBKMX=((BFMINMAX(I,3)+XS)/TXSCAL) YBKMN=((BFMINMAX(I,2)+YS)/TXSCAL) YBKMX=((BFMINMAX(I,4)+YS)/TXSCAL) ! WRITE(90,*) 'BACKGND-cm',XBKMN,XBKMX,YBKMN,YBKMX CALL IGrUnitsToPixels(0.,0.,IXPM,IYPM) CALL IGrUnitsToPixels(HSIZE,8.0,IXPXC,IYPXC) ! WRITE(90,*) 'PIXELS',IXPM,IYPXC-IYPXC,IXPXC,IYPXC-IYPM CALL IGrUnitsToPixels(XBKMN,YBKMN,IXPM,IYPM) CALL IGrUnitsToPixels(XBKMX,YBKMX,IXPX,IYPX) IYPX=IYPXC-IYPX IYPM=IYPXC-IYPM ! WRITE(90,*) 'PIXELS',IXPM,IYPX,IXPX,IYPM,IXPXC,IYPXC IF(XBKMN .GT. HSIZE) RETURN IF(XBKMX .LT. 0.) RETURN IF(YBKMN .GT. 8.) RETURN IF(YBKMX .LT. 0.) RETURN CALL IGrFileInfo(BFNAME(I),INFO,6) ! WRITE(90,*)'BITMAP INFO',INFO IF(INFO(1) .EQ. 1 .or. info(1) .eq. 2 .or. info(1) .eq. 15 .or. info(1) .eq. 19) THEN IXPIX=INFO(2) IYPIX=INFO(3) ENDIF XRANGE=IXPX-IXPM YRANGE=IYPM-IYPX ! WRITE(90,*) 'RANGE',XRANGE,YRANGE FRACX1=0. FRACX2=0. FRACY1=0. FRACY2=0. IF(IXPX .GT. IXPXC) THEN FRACX1=(IXPX-IXPXC)/XRANGE IXPX = IXPXC ENDIF IF(IYPM .GT. IYPXC) THEN FRACY1=(IYPM-IYPXC)/YRANGE IYPM = IYPXC ENDIF IF(IXPM .LT. 0) THEN FRACX2=-IXPM/XRANGE IXPM=0 ENDIF IF(IYPX .LT. 0) THEN FRACY2=-IYPX/YRANGE IYPX=0 ENDIF ! WRITE(90,*) 'BACKGN2-bm',IXPM,IYPX,IXPX,IYPM ! WRITE(90,*) 'FRAC-bm ',FRACX1,FRACX2,FRACY1,FRACY2 IF(IHAND1 .NE. 0) THEN CALL WBitmapDestroy(IHAND1) CALL WBitmapDestroy(IHAND2) ENDIF ! WRITE(90,*) 'PIXEL INFO',IXPIX,IYPIX CALL WBitMapCreate(IHAND1,IXPIX,IYPIX) IERR = InfoError(LastError) ! WRITE(90,*) 'ERROR CREATE', IERR,IHAND1 CALL IGrSelect(DrawBitmap,IHAND1) if(ihand1 .eq. 0) then IERR = InfoError(LastError) CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,& 'Too many pixels for image to display correctly '//CHAR(13)//'Image will not register ','IMAGE ERROR') endif ! WRITE(90,*) 'ERROR SELECT', IERR CALL IGrLoadImage(BFNAME(I),1) IERR = InfoError(LastError) ! WRITE(90,*) 'ERROR LOAD', IERR IX2PIX=IXPIX*(1.-FRACX1-FRACX2) IY2PIX=IYPIX*(1.-FRACY1-FRACY2) IXLPIX=IXPIX*FRACX2 IYLPIX=IYPIX*FRACY2 IXMPIX=IXPIX*(1.-FRACX1) IYMPIX=IYPIX*(1.-FRACY1) ! WRITE(90,*) 'HANDL2',IHAND2,IX2PIX,IY2PIX ! WRITE(90,*) 'LOCAL ',IXLPIX,IYLPIX,IXMPIX,IYMPIX CALL WBitMapCreate(IHAND2,IX2PIX,IY2PIX) CALL IGrSelect(DrawBitmap,IHAND2) CALL WBitMapPutPart(IHAND1,0,IXLPIX,IYLPIX,IXMPIX,IYMPIX) IF(IDDSW .EQ. 1) THEN CALL IGrSelect(DrawWin) ELSE CALL IGrSelect(DrawBitmap,IHANDLE) ENDIF IERR = InfoError(LastError) ! WRITE(90,*) 'ERROR SELECT DRAW', IERR CALL WBitmapPut(IHAND2,1,1,IXPM,IYPX,IXPX,IYPM) ! call gim_an_event(ix,iy,iflag) RETURN END Subroutine panel012(ibkon) use winteracter implicit none include 'D.inc' INCLUDE 'BFILES.I90' ! ! Declare window-type and message variables ! TYPE(WIN_STYLE) :: WINDOW TYPE(WIN_MESSAGE) :: MESSAGE integer :: n,ibkon,IERR ! real :: character*3 :: sub call wdialogload(IDD_DIALOG012) ierr=infoerror(1) do n=1,nbkfl CALL WDialogPutString(idf_string1+n-1,BFNAME(n)) call wdialogputcheckbox(idf_check1+n-1,iswbkfl(n)) enddo call wdialogputcheckbox(idf_check11,ibkon) CALL WDialogSelect(IDD_DIALOG012) ierr=infoerror(1) CALL WDialogShow(-1,-1,0,Modal) ierr=infoerror(1) IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN do n=1,nbkfl call wdialogGetcheckbox(idf_check1+n-1,iswbkfl(n)) CALL GETSUB(BFNAME(n),SUB) if(sub .eq. 'bmp') then if(iswbkfl(n) .eq. 1) iswbkfl(n)=2 ELSEIF(SUB .EQ. 'pcx') then if(iswbkfl(n) .eq. 1) ISWBKFL(N) = 2 ELSEIF(SUB .EQ. 'png' .or. sub .eq. 'jpg') then if(iswbkfl(n) .eq. 1) ISWBKFL(N) = 2 endif enddo call wdialogGetcheckbox(idf_check11,ibkon) ENDIF RETURN END SUBROUTINE UNDO(IYES) USE WINTERACTER INCLUDE 'D.INC' CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do wish to undo?'//& CHAR(13)//' ','Undo option') ! ! If answer 'No', return ! iyes=1 IF (WInfoDialog(4).EQ.2) iyes=0 return end subroutine frame(xmn,ymn,xmx,ymx) CALL PLOTT(xmn,ymn,3) CALL PLOTT(xmx,ymn,2) CALL PLOTT(xmx,ymx,2) CALL PLOTT(xmn,ymx,2) CALL PLOTT(xmn,ymn,2) return end SUBROUTINE CIRCLE(CX,CY,rad) dimension x(8),y(8) DO I=1,8 ANGLE=FLOAT(I-1)*6.28318/8. X(I)=CX+rad*COS(ANGLE) Y(I)=CY+rad*SIN(ANGLE) ENDDO ! write(90,*) 'circle',x,y CALL IGrPolygonComplex(x,y,8) return end Subroutine GETHDRTYP(IHDSWT) use winteracter implicit none include 'D.inc' ! ! Declare window-type and message variables ! TYPE(WIN_STYLE) :: WINDOW TYPE(WIN_MESSAGE) :: MESSAGE integer :: IHDSWT,IERR call wdialogload(IDD_HEADERTP) ierr=infoerror(1) call wdialogputRadioButton(idf_radio1) CALL WDialogSelect(IDD_HEADERTP) ierr=infoerror(1) CALL WDialogShow(-1,-1,0,Modal) ierr=infoerror(1) do IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN call wdialoggetradiobutton(idf_radio1,IHDSWT) return endif IHDSWT=1 RETURN enddo RETURN END Subroutine panelfil use winteracter implicit none include 'D.inc' INCLUDE 'BFILES.I90' ! ! Declare window-type and message variables ! TYPE(WIN_STYLE) :: WINDOW TYPE(WIN_MESSAGE) :: MESSAGE integer :: n,iflon,IERR ! real :: character*3 :: sub call wdialogload(IDD_SELTFL2) ierr=infoerror(1) write(90,*) 'iactvfil,itotfil',iactvfil,itotfil do n=1,itotfil write(90,'(a)') 'file',n,fnameout(n) CALL WDialogPutString(idf_string25+n-1,FNAMEOUT(n)) if(n .eq. iactvfil) then call wdialogputradiobutton(idf_radio1+n-1) endif enddo CALL WDialogSelect(IDD_SELTFL2) ierr=infoerror(1) CALL WDialogShow(-1,-1,0,Modal) ierr=infoerror(1) DO IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN call wdialogGetradiobutton(idf_radio1,iactvfil) write(90,*) 'Selected iactvfil', iactvfil RETURN ELSEIF (WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN RETURN ENDIF ENDDO END subroutine plotcr(x,y,siz) CALL PLOTT(x-siz/2.,y,3) CALL PLOTT(x+siz/2,y,2) CALL PLOTT(x,y-siz/2.,3) CALL PLOTT(x,y+siz/2.,2) return end SUBROUTINE OUTJPGW(FNAME,INFO) CHARACTER(LEN=255) :: FNAME INTEGER INFO(3) INCLUDE 'TXFRM.COM' REAL HSIZE COMMON /SSIZE/ HSIZE XR=HSIZE*TXSCAL-XS YT=8.0*TXSCAL-YS XSIZ=HSIZE*TXSCAL/FLOAT(INFO(2)) YSIZ=-8*TXSCAL/FLOAT(INFO(3)) OPEN(104,FILE=FNAME,STATUS ='UNKNOWN', FORM ='FORMATTED') WRITE(104,*) XSIZ WRITE(104,*) ' 0.0' WRITE(104,*) ' 0.0' WRITE(104,*) YSIZ WRITE(104,*) -XS WRITE(104,*) YT CLOSE(104) RETURN END