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.
205 lines
4.8 KiB
Fortran
205 lines
4.8 KiB
Fortran
5 years ago
|
!ipk last change July 14 updating of cycw changes in 97
|
||
|
|
! Last change: IPK 12 Jan 98 1:55 pm
|
||
|
|
!ipk last update Nov 18 1997
|
||
|
|
!ipk last updated Oct 17 1996
|
||
|
|
!ipk last updated Oct 14 1996
|
||
|
|
|
||
|
|
SUBROUTINE RDRW(IS)
|
||
|
|
|
||
|
|
! Determine how to draw grid according to switch setting
|
||
|
|
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
CHARACTER*1 ANS,ANSW(10)
|
||
|
|
character*38 mesg
|
||
|
|
|
||
|
|
! Draw box around selections
|
||
|
|
|
||
|
|
DATA ANSW/'m','o','e','n','t','y','l','d','b','r'/
|
||
|
|
! m 1 o 2 e 5 n 3 t 4 u 7 g 8 d 6 b 9
|
||
|
|
NHTP=5
|
||
|
|
NMESS=0
|
||
|
|
NBRR=0
|
||
|
|
100 CONTINUE
|
||
|
|
CALL HEDR
|
||
|
|
|
||
|
|
! Get answer
|
||
|
|
|
||
|
|
call xyloc(XPT,YPT,ANS,IBOX)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
if(ibox .le. 0) go to 100
|
||
|
|
IF(ANS .EQ. 'c') THEN
|
||
|
|
ANS=ANSW(IBOX)
|
||
|
|
ENDIF
|
||
|
|
IF(ANS .EQ. 'm') THEN
|
||
|
|
!ipk oct96
|
||
|
|
if(ipsw(1) .eq. 0) then
|
||
|
|
call getmpcl
|
||
|
|
NHTP=5
|
||
|
|
endif
|
||
|
|
!ipk oc96 end addition
|
||
|
|
IPSW(1)=MOD(IPSW(1)+1,2)
|
||
|
|
GO TO 100
|
||
|
|
ELSEIF(ANS .EQ. 'o') THEN
|
||
|
|
IPSW(2)=MOD(IPSW(2)+1,2)
|
||
|
|
GO TO 100
|
||
|
|
ELSEIF(ANS .EQ. 'n') THEN
|
||
|
|
IPSW(3)=MOD(IPSW(3)+1,2)
|
||
|
|
IF(IPSW(3) .EQ. 1) IPSW(9)=0
|
||
|
|
IF(IPSW(3) .EQ. 1) IPSW(14)=0
|
||
|
|
GO TO 100
|
||
|
|
ELSEIF(ANS .EQ. 't') THEN
|
||
|
|
IPSW(4)=MOD(IPSW(4)+1,2)
|
||
|
|
GO TO 100
|
||
|
|
ELSEIF(ANS .EQ. 'e') THEN
|
||
|
|
IPSW(5)=MOD(IPSW(5)+1,2)
|
||
|
|
if(ipsw(5) .eq. 1) ipsw(7)=0
|
||
|
|
GO TO 100
|
||
|
|
ELSEIF(ANS .EQ. 'd') THEN
|
||
|
|
IPSW(6)=MOD(IPSW(6)+1,2)
|
||
|
|
if(ipsw(6) .eq. 1) then
|
||
|
|
!ipk apr02
|
||
|
|
call getmdis(nmapf,nsigf,icolsw,rad,colint)
|
||
|
|
! write(mesg,*) 'Enter output frequency for map display'
|
||
|
|
! call symbl (1.1,7.3,0.25,mesg,0.0,38)
|
||
|
|
! call getint(nmapf)
|
||
|
|
endif
|
||
|
|
GO TO 100
|
||
|
|
ELSEIF(ANS .EQ. 'y') THEN
|
||
|
|
IPSW(7)=MOD(IPSW(7)+1,2)
|
||
|
|
if(ipsw(7) .eq. 1) ipsw(5)=0
|
||
|
|
GO TO 100
|
||
|
|
!ipk feb01 drop this option in favour of ccline ELSEIF(ANS .EQ. 'g') THEN
|
||
|
|
!ipk feb01 IPSW(8)=MOD(IPSW(8)+1,2)
|
||
|
|
!ipk feb01 GO TO 100
|
||
|
|
ELSEIF(ANS .EQ. 'l') THEN
|
||
|
|
IPSW(10)=MOD(IPSW(10)+1,2)
|
||
|
|
GO TO 100
|
||
|
|
ELSEIF(ANS .EQ. 'b') THEN
|
||
|
|
IPSW(9)=MOD(IPSW(9)+1,2)
|
||
|
|
IF(IPSW(9) .EQ. 1) IPSW(3)=0
|
||
|
|
IF(IPSW(9) .EQ. 1) IPSW(14)=0
|
||
|
|
GO TO 100
|
||
|
|
ELSEIF(ANS .EQ. 'r') THEN
|
||
|
|
|
||
|
|
! CALL PLOTS(IS)
|
||
|
|
!ipk nov97 add (0)
|
||
|
|
CALL PLOTOT(1)
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
GO TO 100
|
||
|
|
END
|
||
|
|
|
||
|
|
SUBROUTINE GETMPCL
|
||
|
|
|
||
|
|
! Determine how to draw grid according to switch setting
|
||
|
|
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
CHARACTER*1 ANS,ANSW(10)
|
||
|
|
|
||
|
|
! Draw box around selections
|
||
|
|
|
||
|
|
DATA ANSW/'e','o','t','h','f','i','s','v','g','q'/
|
||
|
|
! m 1 o 2 e 5 n 3 t 4 u 7 g 8 d 6 b 9
|
||
|
|
NHTP=12
|
||
|
|
100 CONTINUE
|
||
|
|
CALL HEDR
|
||
|
|
|
||
|
|
! Get answer
|
||
|
|
|
||
|
|
call xyloc(XPT,YPT,ANS,IBOX)
|
||
|
|
IF(ANS .NE. 'c') then
|
||
|
|
DO K=1,10
|
||
|
|
IF(ANS .EQ. ANSW(K)) THEN
|
||
|
|
IBOX=K
|
||
|
|
GO TO 102
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
102 CONTINUE
|
||
|
|
ENDIF
|
||
|
|
IF(IBOX .EQ. 10) GO TO 150
|
||
|
|
ICOLON(IBOX)=MOD(ICOLON(IBOX)+1,2)
|
||
|
|
CALL HEDR
|
||
|
|
GO TO 100
|
||
|
|
150 NHTP=5
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
SUBROUTINE GDIST
|
||
|
|
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
CHARACTER*1 ANS,ANSW(10)
|
||
|
|
|
||
|
|
|
||
|
|
INCLUDE 'TXFRM.COM'
|
||
|
|
!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL
|
||
|
|
|
||
|
|
DATA ANSW/6*' ','n','z','r','q'/
|
||
|
|
!
|
||
|
|
NHTPSV=NHTP
|
||
|
|
NMESSV=NMESS
|
||
|
|
NBRRSV=NBRR
|
||
|
|
100 CONTINUE
|
||
|
|
NHTP=0
|
||
|
|
NMESS=41
|
||
|
|
NBRR=4
|
||
|
|
CALL CLRBOX
|
||
|
|
CALL HEDR
|
||
|
|
call xyloc(XPT1,YPT1,ANS,IBOX)
|
||
|
|
call xyloc(XPT2,YPT2,ANS,IBOX)
|
||
|
|
DIST=SQRT((YPT2-YPT1)**2+(XPT2-XPT1)**2)*TXSCAL
|
||
|
|
CALL CLRBOX
|
||
|
|
NMESS=0
|
||
|
|
NBRR=4
|
||
|
|
CALL HEDR
|
||
|
|
CALL NUMBR(0.5,7.55,0.20,DIST,0.0,2)
|
||
|
|
CALL XYLOC(XPT1,YPT1,ANS,IBOX)
|
||
|
|
IF(ANS .NE. 'c') then
|
||
|
|
DO K=1,10
|
||
|
|
IF(ANS .EQ. ANSW(K)) THEN
|
||
|
|
IBOX=K
|
||
|
|
GO TO 102
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
102 CONTINUE
|
||
|
|
ENDIF
|
||
|
|
IF(IBOX .EQ. 7) GO TO 100
|
||
|
|
NHTP=NHTPSV
|
||
|
|
NMESS=NMESSV
|
||
|
|
NBRR=NBRRSV
|
||
|
|
CALL CLRBOX
|
||
|
|
CALL HEDR
|
||
|
|
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
|
||
|
|
SUBROUTINE CHEXIT
|
||
|
|
USE WINTERACTER
|
||
|
|
TYPE(WIN_MESSAGE) :: MESSAGE
|
||
|
|
INTEGER :: ITYPE
|
||
|
|
COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout
|
||
|
|
|
||
|
|
CALL WMessagePeek(ITYPE, MESSAGE)
|
||
|
|
|
||
|
|
SELECT CASE (ITYPE)
|
||
|
|
CASE (-1)
|
||
|
|
RETURN
|
||
|
|
CASE (KeyDown) ! Key pressed
|
||
|
|
IPSW(1)=0
|
||
|
|
IPSW(2)=1
|
||
|
|
IPSW(3)=0
|
||
|
|
IPSW(4)=0
|
||
|
|
IPSW(5)=0
|
||
|
|
IPSW(6)=0
|
||
|
|
IPSW(7)=0
|
||
|
|
IPSW(8)=0
|
||
|
|
IPSW(9)=0
|
||
|
|
IPSW(12)=0
|
||
|
|
RETURN
|
||
|
|
ENDSELECT
|
||
|
|
RETURN
|
||
|
|
END
|