iank
/
RMAGEN84
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
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.
master
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from '601f33fc45'
${ noResults }
RMAGEN84/SRC84/REGSTR.F90

345 lines
9.0 KiB
Fortran
Raw Blame History

! 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
Reference in New Issue View Git Blame Copy Permalink