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.
345 lines
9.0 KiB
Fortran
345 lines
9.0 KiB
Fortran
5 years ago
|
! Last change: IPK 24 Aug 2001 3:08 pm
|
||
|
|
SUBROUTINE REGISTR(I)
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
INCLUDE 'BFILES.I90'
|
||
|
|
|
||
|
|
CALL SLPOINT(A1,B1,A2,B2,C1,D1,C2,D2,N)
|
||
|
|
!
|
||
|
|
! A1 = X CORD OF DESIRED WORLD-1
|
||
|
|
! B1 = Y CORD OF DESIRED WORLD-1
|
||
|
|
! A2 = X CORD OF DESIRED WORLD-2
|
||
|
|
! B2 = X CORD OF DESIRED WORLD-2
|
||
|
|
! C1 = X CORD OF INPUT WORLD-1
|
||
|
|
! D1 = Y CORD OF INPUT WORLD-1
|
||
|
|
! C2 = X CORD OF INPUT WORLD-2
|
||
|
|
! D2 = X CORD OF INPUT WORLD-2
|
||
|
|
|
||
|
|
IF(N .EQ. 1) THEN
|
||
|
|
|
||
|
|
! Compute new locations
|
||
|
|
|
||
|
|
SCALEER= (A2-A1)/(C2-C1)
|
||
|
|
ASIZ=(BFMINMAX(I,3)-BFMINMAX(I,1))*SCALEER
|
||
|
|
FLEFT=(C1-BFMINMAX(I,1))/(BFMINMAX(I,3)-BFMINMAX(I,1))
|
||
|
|
XNEW1=A1-FLEFT*ASIZ
|
||
|
|
XNEW2=XNEW1+ASIZ
|
||
|
|
WRITE(90,*) 'X-SCAL',SCALEER,ASIZ,FLEFT,XNEW1,XNEW2
|
||
|
|
SCALEER= (B2-B1)/(D2-D1)
|
||
|
|
BSIZ=(BFMINMAX(I,4)-BFMINMAX(I,2))*SCALEER
|
||
|
|
FBEL=(D1-BFMINMAX(I,2))/(BFMINMAX(I,4)-BFMINMAX(I,2))
|
||
|
|
YNEW1=B1-FBEL*BSIZ
|
||
|
|
YNEW2=YNEW1+BSIZ
|
||
|
|
WRITE(90,*) 'Y-SCAL',SCALEER,BSIZ,FBEL,YNEW1,YNEW2
|
||
|
|
|
||
|
|
! Confirm that they are acceptable
|
||
|
|
|
||
|
|
CALL DISPREG(BFMINMAX(I,1),BFMINMAX(I,2),BFMINMAX(I,3),BFMINMAX(I,4),XNEW1,YNEW1,XNEW2,YNEW2,NN)
|
||
|
|
WRITE(90,*) 'AFTER DIS',NN,XNEW1,YNEW1,XNEW2,YNEW2
|
||
|
|
|
||
|
|
! Store them in the appropriate array
|
||
|
|
|
||
|
|
IF(NN .EQ. 1) THEN
|
||
|
|
BFMINMAX(I,1)=XNEW1
|
||
|
|
BFMINMAX(I,2)=YNEW1
|
||
|
|
BFMINMAX(I,3)=XNEW2
|
||
|
|
BFMINMAX(I,4)=YNEW2
|
||
|
|
ELSE
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
! Save them if they are wanted
|
||
|
|
|
||
|
|
CALL SAVORG(I,1)
|
||
|
|
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
RETURN
|
||
|
|
END SUBROUTINE
|
||
|
|
|
||
|
|
! Display selected origins
|
||
|
|
|
||
|
|
SUBROUTINE DISPREG(A1,B1,A2,B2,C1,D1,C2,D2,NN)
|
||
|
|
|
||
|
|
! This subroutine gets points
|
||
|
|
!
|
||
|
|
USE WINTERACTER
|
||
|
|
|
||
|
|
IMPLICIT NONE
|
||
|
|
!
|
||
|
|
! Define some parameters to match those in the resource file
|
||
|
|
!
|
||
|
|
include 'd.inc'
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! Declare window-type and message variables
|
||
|
|
!
|
||
|
|
TYPE(WIN_STYLE) :: WINDOW
|
||
|
|
|
||
|
|
TYPE(WIN_MESSAGE) :: MESSAGE
|
||
|
|
|
||
|
|
INTEGER :: N,IBOX,NN
|
||
|
|
INTEGER :: IERR
|
||
|
|
REAL :: A1,B1,A2,B2,C1,D1,C2,D2
|
||
|
|
CHARACTER*1 :: IFLAG
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
call wdialogload(IDD_CONFIRM)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogSelect(IDD_CONFIRM)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogPutReal(IDF_REAL1,A1,'(F8.0)')
|
||
|
|
CALL WDialogPutReal(IDF_REAL2,B1,'(F8.0)')
|
||
|
|
CALL WDialogPutReal(IDF_REAL5,A2,'(F8.0)')
|
||
|
|
CALL WDialogPutReal(IDF_REAL6,B2,'(F8.0)')
|
||
|
|
CALL WDialogPutReal(IDF_REAL3,C1,'(F8.0)')
|
||
|
|
CALL WDialogPutReal(IDF_REAL4,D1,'(F8.0)')
|
||
|
|
CALL WDialogPutReal(IDF_REAL7,C2,'(F8.0)')
|
||
|
|
CALL WDialogPutReal(IDF_REAL8,D2,'(F8.0)')
|
||
|
|
|
||
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
do
|
||
|
|
|
||
|
|
! Branch depending on type of message.
|
||
|
|
!
|
||
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||
|
|
NN=1
|
||
|
|
CALL WDialogGetReal(IDF_REAL1,A1)
|
||
|
|
CALL WDialogGetReal(IDF_REAL2,B1)
|
||
|
|
CALL WDialogGetReal(IDF_REAL5,A2)
|
||
|
|
CALL WDialogGetReal(IDF_REAL6,B2)
|
||
|
|
CALL WDialogGetReal(IDF_REAL3,C1)
|
||
|
|
CALL WDialogGetReal(IDF_REAL4,D1)
|
||
|
|
CALL WDialogGetReal(IDF_REAL7,C2)
|
||
|
|
CALL WDialogGetReal(IDF_REAL8,D2)
|
||
|
|
RETURN
|
||
|
|
ELSEIF(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN
|
||
|
|
NN=0
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
!ipk sep02
|
||
|
|
NN=0
|
||
|
|
RETURN
|
||
|
|
ENDDO
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
! Select points
|
||
|
|
|
||
|
|
SUBROUTINE SLPOINT(A1,B1,A2,B2,C1,D1,C2,D2,NN)
|
||
|
|
!
|
||
|
|
! This subroutine gets points
|
||
|
|
!
|
||
|
|
USE WINTERACTER
|
||
|
|
|
||
|
|
IMPLICIT NONE
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! Define some parameters to match those in the resource file
|
||
|
|
!
|
||
|
|
include 'd.inc'
|
||
|
|
|
||
|
|
INTEGER :: NP,NE,NHTP,NMESS,NBRR,IPSW,IRMAIN,ISCRN,icolon,IQSW,IRDISP,ntempin,IGFGSW,IGFGSWB,ICRIN,IPW1,WIDEL,WIDSCL,itrianout
|
||
|
|
COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout
|
||
|
|
|
||
|
|
|
||
|
|
INCLUDE 'TXFRM.COM'
|
||
|
|
!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL
|
||
|
|
!
|
||
|
|
|
||
|
|
!
|
||
|
|
! Declare window-type and message variables
|
||
|
|
!
|
||
|
|
TYPE(WIN_STYLE) :: WINDOW
|
||
|
|
|
||
|
|
TYPE(WIN_MESSAGE) :: MESSAGE
|
||
|
|
|
||
|
|
INTEGER :: N,IBOX,NN
|
||
|
|
INTEGER :: IERR
|
||
|
|
!IPK MAY02
|
||
|
|
REAL :: A1,B1,A2,B2,C1,D1,C2,D2,XX,YY
|
||
|
|
CHARACTER*1 :: IFLAG
|
||
|
|
|
||
|
|
|
||
|
|
call wdialogload(IDD_SLRGNO)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogSelect(IDD_SLRGNO)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogPutINTEGER(IDF_INTEGER1,N)
|
||
|
|
|
||
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
do
|
||
|
|
|
||
|
|
! Branch depending on type of message.
|
||
|
|
!
|
||
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||
|
|
|
||
|
|
CALL WDialogGetINTEGER(IDF_INTEGER1,N)
|
||
|
|
GO TO 150
|
||
|
|
ENDIF
|
||
|
|
!ipk sep02
|
||
|
|
RETURN
|
||
|
|
ENDDO
|
||
|
|
150 CONTINUE
|
||
|
|
|
||
|
|
NHTP=0
|
||
|
|
NBRR=3
|
||
|
|
NMESS=43
|
||
|
|
CALL HEDR
|
||
|
|
WRITE(90,*) 'BACK FROM HEDR'
|
||
|
|
IF(N .EQ. 1) THEN
|
||
|
|
CALL XYLOC(XX,YY,iflag,ibox)
|
||
|
|
C1 = XX*TXSCAL - XS
|
||
|
|
D1 = YY*TXSCAL - YS
|
||
|
|
WRITE(90,*) 'BACK FROM XYLOC-1',C1,D1,IBOX,IFLAG
|
||
|
|
ELSE
|
||
|
|
CALL XYLOC(XX,YY,iflag,ibox)
|
||
|
|
C2 = XX*TXSCAL - XS
|
||
|
|
D2 = YY*TXSCAL - YS
|
||
|
|
WRITE(90,*) 'BACK FROM XYLOC-2',C2,D2,IBOX,IFLAG
|
||
|
|
ENDIF
|
||
|
|
IF(IFLAG .EQ. 'q' .OR. (IFLAG .EQ. 'c' .AND. IBOX .EQ. 10))THEN
|
||
|
|
CALL WRTOUT(0)
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
call wdialogload(IDD_REGST)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogSelect(IDD_REGST)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogPutReal(IDF_REAL1,A1,'(F8.0)')
|
||
|
|
CALL WDialogPutReal(IDF_REAL2,B1,'(F8.0)')
|
||
|
|
CALL WDialogPutReal(IDF_REAL3,A2,'(F8.0)')
|
||
|
|
CALL WDialogPutReal(IDF_REAL4,B2,'(F8.0)')
|
||
|
|
CALL WDialogPutReal(IDF_REAL5,C1,'(F8.0)')
|
||
|
|
CALL WDialogPutReal(IDF_REAL6,D1,'(F8.0)')
|
||
|
|
CALL WDialogPutReal(IDF_REAL7,C2,'(F8.0)')
|
||
|
|
CALL WDialogPutReal(IDF_REAL8,D2,'(F8.0)')
|
||
|
|
|
||
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
do
|
||
|
|
|
||
|
|
! Branch depending on type of message.
|
||
|
|
!
|
||
|
|
IF (WInfoDialog(ExitButton) .EQ. IDADJUST) THEN
|
||
|
|
|
||
|
|
CALL WDialogGetReal(IDF_REAL1,A1)
|
||
|
|
CALL WDialogGetReal(IDF_REAL2,B1)
|
||
|
|
CALL WDialogGetReal(IDF_REAL3,A2)
|
||
|
|
CALL WDialogGetReal(IDF_REAL4,B2)
|
||
|
|
CALL WDialogGetReal(IDF_REAL5,C1)
|
||
|
|
CALL WDialogGetReal(IDF_REAL6,D1)
|
||
|
|
CALL WDialogGetReal(IDF_REAL7,C2)
|
||
|
|
CALL WDialogGetReal(IDF_REAL8,D2)
|
||
|
|
NN=1
|
||
|
|
RETURN
|
||
|
|
ELSEIF (WInfoDialog(ExitButton) .EQ. IDFSWITCH) THEN
|
||
|
|
|
||
|
|
CALL WDialogGetReal(IDF_REAL1,A1)
|
||
|
|
CALL WDialogGetReal(IDF_REAL2,B1)
|
||
|
|
CALL WDialogGetReal(IDF_REAL3,A2)
|
||
|
|
CALL WDialogGetReal(IDF_REAL4,B2)
|
||
|
|
CALL WDialogGetReal(IDF_REAL5,C1)
|
||
|
|
CALL WDialogGetReal(IDF_REAL6,D1)
|
||
|
|
CALL WDialogGetReal(IDF_REAL7,C2)
|
||
|
|
CALL WDialogGetReal(IDF_REAL8,D2)
|
||
|
|
IF(N .EQ. 1) THEN
|
||
|
|
N=2
|
||
|
|
ELSE
|
||
|
|
N=1
|
||
|
|
ENDIF
|
||
|
|
GO TO 150
|
||
|
|
ELSEIF (WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN
|
||
|
|
NN=0
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
!IPK SEP02
|
||
|
|
NN=0
|
||
|
|
RETURN
|
||
|
|
ENDDO
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
|
||
|
|
SUBROUTINE SAVORG(NN,III)
|
||
|
|
|
||
|
|
! This subroutine askf to check first then saves ORG file data
|
||
|
|
!
|
||
|
|
USE WINTERACTER
|
||
|
|
|
||
|
|
IMPLICIT NONE
|
||
|
|
!
|
||
|
|
! Define some parameters to match those in the resource file
|
||
|
|
!
|
||
|
|
include 'd.inc'
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! Declare window-type and message variables
|
||
|
|
!
|
||
|
|
TYPE(WIN_STYLE) :: WINDOW
|
||
|
|
|
||
|
|
TYPE(WIN_MESSAGE) :: MESSAGE
|
||
|
|
|
||
|
|
INCLUDE 'BFILES.I90'
|
||
|
|
CHARACTER(LEN=256) :: FILTER
|
||
|
|
|
||
|
|
INTEGER :: NN,I,III
|
||
|
|
CHARACTER(LEN=255) :: FNAME
|
||
|
|
CHARACTER(LEN=3) :: SUB
|
||
|
|
INTEGER :: INFO(3)
|
||
|
|
REAL :: XSIZ,YSIZ
|
||
|
|
IF(III .EQ. 1) THEN
|
||
|
|
CALL WMessageBox(YesNo,QuestionIcon,CommonOK, 'Do you wish to '// &
|
||
|
|
'save locations as ORG or JPGW file?', 'SAVE ORG/JPGW FILE')
|
||
|
|
!
|
||
|
|
! If answer 'NO', return
|
||
|
|
!
|
||
|
|
IF (WInfoDialog(4) .EQ. 2) RETURN
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
! Otherwise process
|
||
|
|
call IGrFileInfo(BFNAME(NN),INFO,3)
|
||
|
|
|
||
|
|
FILTER ="Registration Files|*.org;*.jpgw|ORG file -- *.org|*.org|JPGW file -- *.jpgw|*.jpgw|"
|
||
|
|
|
||
|
|
CALL WSelectFile(FILTER,SaveDialog+PromptOn+AppendExt,FNAME,'Save ORG/JPGW File')
|
||
|
|
|
||
|
|
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||
|
|
|
||
|
|
! SUB='org'
|
||
|
|
OPEN(104,FILE=FNAME,STATUS ='UNKNOWN', FORM ='FORMATTED')
|
||
|
|
CALL IlowerCase(FNAME)
|
||
|
|
CALL GETSUB(FNAME,SUB)
|
||
|
|
if(sub .eq. 'jpg') then
|
||
|
|
XSIZ=(BFMINMAX(NN,3)-BFMINMAX(NN,1))/FLOAT(INFO(2))
|
||
|
|
YSIZ=(BFMINMAX(NN,2)-BFMINMAX(NN,4))/FLOAT(INFO(3))
|
||
|
|
WRITE(104,*) XSIZ
|
||
|
|
WRITE(104,*) ' 0.0'
|
||
|
|
WRITE(104,*) ' 0.0'
|
||
|
|
WRITE(104,*) YSIZ
|
||
|
|
WRITE(104,*) BFMINMAX(NN,1)
|
||
|
|
WRITE(104,*) BFMINMAX(NN,4)
|
||
|
|
CLOSE(104)
|
||
|
|
else
|
||
|
|
! CALL ADDSUB(FNAME,SUB)
|
||
|
|
! OPEN(104,FILE=FNAME,STATUS ='UNKNOWN', FORM ='FORMATTED')
|
||
|
|
WRITE(104,'(4G16.8)') (BFMINMAX(NN,I),I=1,4)
|
||
|
|
CLOSE(104)
|
||
|
|
endif
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
RETURN
|
||
|
|
END
|