You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
730 lines
16 KiB
Fortran
730 lines
16 KiB
Fortran
!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
|
|
|