! 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