SUBROUTINE PROFLR(*,OPTION,OUTDEV,FONT, & TITLEE,ITOSEC,LUPLP,LUPLT, & XLEFT,XRIGHT,XLEN,XINC,XDIV, & YUP,YDOWN,YLEN,YINC,YDIV, & ZMIN,ZMAX,ZLEN,ZINC,ZDIV, & PF,QF) C C THIS SUBROUTINE IS USED FOR PLOTTING MORE THAN ONE INPUT C SOUND SPEED PROFILE IN THE SAME FRAME DEPENDING ON INPUT SCALES. PARAMETER (NPTR=400) CHARACTER*80 TITLEE CHARACTER*1 ZZ,DUMMY CHARACTER*12 OPTION CHARACTER*4 RDP CHARACTER*3 XBTYPE,YBTYPE,ZBTYPE CHARACTER*5 OPT CHARACTER*80 TITX,TITY,TITZ CHARACTER*80 BUFF CHARACTER*2 FORMT, BDEV CHARACTER*3 SYMB(20), ADD, CURVET, URC, ULC, NWR CHARACTER*3 DEV, SIM(10) CHARACTER*3 PLOP(21), FONT CHARACTER*11 FACTORTMP REAL BUFFIN(3) DIMENSION Z(100),C(100),Z1(100),C1(100) DIMENSION TRACK1(NPTR),TRACK2(NPTR) DIMENSION PF(1),QF(1) LOGICAL BATCH, IDT COMMON /SETPRM/ PLOP, ADD, BDEV, FACTORTMP, & SYMB, DEV, FORMT, URC, ULC, NWR COMMON /SETLOG / IFLG13,IDT COMMON /XAXC/ TITX,XBTYPE COMMON /YAXC/ TITY,YBTYPE COMMON /ZAXC/ TITZ,ZBTYPE DATA XOR,YOR /1.5,1.0/ DATA HGTC/0.1015/ C IXAX=1 IYAX=1 ICHTYP=1 ITFRAM=0 IXCH=0 IMARK=0 IDASH=0 NOP=0 KTYPE=2 NDEC=1 IUNI=0 ICON=0 IHCPY=1 IHGT=NINT(HGTC/0.07)+1 IFLNPT=0 IFLIDX=0 RMAX=XRIGHT XSCALE=ABS(XRIGHT-XLEFT)/XLEN YSCALE=ABS(YDOWN-YUP)/YLEN SSCALE=ABS(ZMAX-ZMIN)/ZLEN SHIFT=0.5*ZLEN/2.54 DXS=ZLEN/((ZMAX-ZMIN)*2.54) DXR=XLEN/((XRIGHT-XLEFT)*2.54) DY=YLEN/((YDOWN-YUP)*2.54) XAX=XLEN/2.54 YAX=YLEN/2.54 XAX13=XLEN/2.54 TSP=.75*XAX 400 FORMAT(A1) 450 FORMAT(A80) DO 123 J=1,21 IF (PLOP(J).EQ.'CPX') ICHTYP=3 IF (PLOP(J).EQ.'SPX') ICHTYP=1 IF (PLOP(J).EQ.'DPX') ICHTYP=2 IF (PLOP(J).EQ.'ITA') ICHTYP=4 IF (PLOP(J).EQ.'IXA') IXAX=1 IF (PLOP(J).EQ.'IYA') IYAX=1 IF (PLOP(J).EQ.'THF') ITFRAM=1 IF (PLOP(J).EQ.'MRK') IMARK=10 IF (PLOP(J).EQ.'DSD') IDASH=1 123 CONTINUE C CALL BGNPL(iplhs) iplhs=iplhs+1 CALL NOBRDR CALL NOCHEK GOTO (701,702,703,704),ICHTYP 701 CALL SIMPLX GOTO 705 702 CALL DUPLX GO TO 705 703 CALL COMPLX GOTO 705 704 CALL COMPLX CALL MX1ALF('ITALIC','}') GOTO 706 705 CALL MX1ALF('STANDA','}') 706 CALL MX2ALF('SUBSCR','!') CALL MX3ALF('SUPERS','#') CALL MX4ALF('GREEK', '%') CALL MX5ALF('ENDSCR','"') CALL MX6ALF('MATHEM','^') CALL MX7ALF('SPECIA','&') CALL MX8ALF('BACKSP','@') DO 10 I=80,2,-2 LN=I IF(TITLEE(I-2:I).NE.' ') GO TO 20 10 CONTINUE 20 CALL HEIGHT(1.5*HGTC) IF(XLEN.LT.YLEN) THEN CALL PAGE(10.0,7.0) ELSE CALL PAGE(7.0,10.0) END IF CALL PHYSOR(SHIFT+1.1,1.1) CALL TITLE(' ',-1,TITX,0,TITY,0,XAX,YAX) IF ( ULC .NE. 'ULC' ) THEN C CALL HEADIN(TITLEE,LN,IHGT,1) CALL MESSAG(TITLEE,LN,.5*XAX-.5*LN*HGTC*1.3,YAX+6.*HGTC) ELSE CALL HEIGHT( 1.7*HGTC ) CALL DUPLX CALL MESSAG( TITLEE, LN, - 6.6 * HGTC, YAX + 1.5*HGTC ) GOTO (4300,4400,4500,4600),ICHTYP 4300 CALL SIMPLX GOTO 4700 4400 CALL DUPLX GO TO 4700 4500 CALL COMPLX GOTO 4700 4600 CALL COMPLX CALL MX1ALF('ITALIC','}') GOTO 4800 4700 CALL MX1ALF('STANDA','}') 4800 CALL MX2ALF('SUBSCR','!') CALL HEIGHT( HGTC ) END IF HGT=0.11 CALL HEIGHT(0.13) IF( NWR .NE. 'NWR') CALL MESSAG(OPTION,12,TSP,YAX*1.04) CALL HEIGHT(1.5*HGTC) CALL XTICKS(2) CALL YTICKS(2) CALL GRAF(XLEFT,XINC,XRIGHT,YDOWN,-YINC,YUP) CALL YAXANG(0.0) IF (IXAX.EQ.1.AND.IYAX.EQ.1) THEN CALL INTAXS ELSE IF (IXAX.EQ.1) THEN CALL XINTAX ELSE IF (IYAX.EQ.1) THEN CALL YINTAX ELSE END IF CALL YGRAXS(YDOWN,-YINC,YUP,YAX,TITY,12,-SHIFT,0.) CALL XGRAXS(XLEFT,XINC,XRIGHT,XAX13,TITX,12,0.,0.) CALL VECTOR(0.,YAX,XAX,YAX,0) CALL VECTOR(XAX,YAX,XAX,0.0,0) NINC=(ZMAX-ZMIN)/ZINC M=0 LLC=1 DO 60 L=1,ITOSEC READ(LUPLP,450) BUFF CALL RFFORM(BUFF,80,BUFFIN,1,3,ERROR) NCW=NINT(BUFFIN(1)) NSPP=NINT(BUFFIN(2)) INDEX=NINT(BUFFIN(3)) IF(NCW.LT.0) THEN IFLNPT=1 NCW=ABS(NCW) END IF IF(INDEX.LT.0) THEN IFLIDX=1 INDEX=ABS(INDEX) END IF READ(LUPLP,*) RST READ(LUPLP,*) DX READ(LUPLP,*) YMIN READ(LUPLP,*) DY READ(LUPLT,*)(Z(I),I=1,NCW) READ(LUPLT,*)(C(I),I=1,NCW) TRACK1(L)=RST/1000. IF(NCW.EQ.0) THEN TRACK2(L)=0.0 ELSE TRACK2(L)=Z(NCW) END IF X1=RST/1000. X11=X1 IF(LLC.EQ.0) GO TO 15 IF(X1.LT.XLEFT) GO TO 60 15 IF(X1.GT.XRIGHT) GO TO 120 X1=(X1-XLEFT)*DXR X2=X1-SHIFT X=X1+SHIFT IF(LLC.NE.1) GO TO 80 N1=ALOG10(ZMAX)+3 CALL NUMB(X-.5*N1*HGT*2./3.,YAX+1.3*HGTC,HGT,ZMAX,0.,0,4) N1=ALOG10(ZMIN)+3 CALL NUMB(X2-.5*N1*HGT*2./3.,YAX+1.3*HGTC,HGT,ZMIN,0.,0,4) 80 CALL VECTOR(X2,YAX,X,YAX,0) DO 30 I=0,NINC X=X2+DXS*ZINC*I 30 CALL VECTOR(X,YAX*1.02,X,YAX,0) IF(LLC.NE.1) GO TO 130 X=X2+(ZLEN/2.54-8*HGT)/2. CALL MESSAG(TITZ,8,X,YAX+3.5*HGTC) LLC=0 130 CALL VECTOR(X1,YAX,X1,0.,0.) 190 IF(NCW.NE.0) GO TO 180 Y=YLEN/2. X=X2+(ZLEN-32*HGT/4.)/2. C CALL SYMBOL(X,Y,HGT/4.,31HNO SOUND SPEED PROFILE IN WATER,0.,31) GO TO 150 180 IFLAG=1 CALL CFRAME(Z,1,NCW,YUP,YDOWN,IFLAG) IF(IFLAG.GE.1) GO TO 140 Y=YLEN/2. X=X2+(ZLEN-28*HGT/4.)/2. C CALL SYMBOL(X,Y,HGT/4.,27HNO VALUES INSIDE DEPTH AXIS,0.,27) GO TO 150 140 IFLAG=1 CALL CFRAME(C,1,NCW,ZMIN,ZMAX,IFLAG) IF(IFLAG.GE.1) GO TO 160 Y=YLEN/2. X=X2+(ZLEN-28*HGT/4.)/2. C IF(X.LT.0.5) X=0.5 C CALL SYMBOL(X,Y,HGT/4.,27HNO VALUES INSIDE SPEED AXIS,0.,27) GO TO 150 160 DO 170 J=1,NCW C(J)=X11-SHIFT/DXR+(C(J)-ZMIN)*DXS/DXR 170 CONTINUE IF(IFLNPT.EQ.0 .AND. IFLIDX.EQ.0) THEN CALL CURVE(C,Z,NCW,0) ELSE IF(IFLNPT.EQ.1 .AND. IFLIDX.EQ.0) THEN CALL CURVE(C,Z,NCW,1) ELSE IF(IFLNPT.EQ.1 .AND. IFLIDX.EQ.1) THEN CALL CURVE(C,Z,NCW,-1) END IF 150 M=M+1 IF(M.GT.14) M=0 60 CONTINUE 120 CONTINUE ISTA=1 DO 210 I=1,ITOSEC IF(TRACK1(I).GE.XLEFT) GO TO 220 ISTA=ISTA+1 GO TO 210 220 IFIN=I IF(TRACK1(I).GE.RMAX.OR.TRACK1(I).GE.XRIGHT) GO TO 230 210 CONTINUE 230 NN=IFIN-ISTA+1 IF (ISTA.NE.1.AND.TRACK1(ISTA).NE.XLEFT) THEN TRACK2(ISTA-1)=TRACK2(ISTA-1)+(XLEFT-TRACK1(ISTA-1))* 1 (TRACK2(ISTA)-TRACK2(ISTA-1))/(TRACK1(ISTA)-TRACK1(ISTA-1)) TRACK1(ISTA-1)=XLEFT ISTA=ISTA-1 NN=NN+1 END IF RRR=AMIN1(RMAX,XRIGHT) IF(TRACK1(IFIN).GT.RRR) THEN TRACK2(IFIN)=TRACK2(IFIN-1)+(RRR-TRACK1(IFIN-1))* 1 (TRACK2(IFIN)-TRACK2(IFIN-1))/(TRACK1(IFIN)-TRACK1(IFIN-1)) TRACK1(IFIN)=RRR GO TO 25 END IF IF(TRACK1(IFIN).EQ.XRIGHT.OR.TRACK1(IFIN).EQ.RMAX) GOTO 25 IF(TRACK1(IFIN).LT.RRR) THEN IFIN=IFIN+1 TRACK1(IFIN)=RRR TRACK2(IFIN)=TRACK2(IFIN-1) NN=NN+1 END IF 25 CALL DASH CALL CFRAME(TRACK2,ISTA,IFIN,YUP,YDOWN,IFLAG) CALL CURVE(TRACK1(ISTA),TRACK2(ISTA),NN,0) CALL RESET('DASH') C IERR=0 27 BUFF=' ' NIN=0 READ(LUPLP,450,END=26)BUFF IF(BUFF(2:7).EQ.'BOTTOM') THEN IERR=0 DO 28 I=1,NPTR READ(LUPLP,*,ERR=29,END=31)TRACK1(I),TRACK2(I) NIN=I 28 CONTINUE GO TO 32 29 IF( NIN.EQ.0) THEN STOP ' NO DATA AFTER BOTTOM OPTION' ELSE C TWO BACKSPACE COMMANDS ARE NEEDED. BACKSPACE(UNIT=LUPLP) BACKSPACE(UNIT=LUPLP) END IF 31 IF( NIN.EQ.0) STOP ' NO DATA AFTER BOTTOM OPTION' 32 CALL SCISSOR(TRACK1,XLEFT,XRIGHT, & TRACK2,YUP,YDOWN,NIN,PF,QF,NOUT) CALL CURVE(TRACK1,TRACK2,NOUT,0) GO TO 27 ELSE c STOP ' ERROR READING BOTTOM' backspace(luplp) END IF 26 CONTINUE C IF (IDT .EQV. .FALSE. ) THEN c CALL ENDPL(-1) CALL ENDPL(0) ELSE CALL ENDPL(0) END IF RST=0. RETURN 1 END C SUBROUTINE NUMB(XLAB,YLAB,HGT,ZC,ANGLEE,NDEC,NCHAR) CHARACTER*6 NDECC C 100 FORMAT(F6.1) 200 FORMAT(I1) 300 FORMAT(I2) 400 FORMAT(I3) 500 FORMAT(I4) C CALL ANGLE(ANGLEE) CALL HEIGHT(HGT) IF(NDEC.GT.0) THEN WRITE(NDECC,100)ZC CALL MESSAG(NDECC,6,XLAB,YLAB) ELSE IZC=NINT(ZC) IF(NCHAR.EQ.4) THEN ASSIGN 500 TO NFORM GO TO 6 ELSE IF(NCHAR-2) 3,4,5 3 ASSIGN 200 TO NFORM GO TO 6 4 ASSIGN 300 TO NFORM GO TO 6 5 ASSIGN 400 TO NFORM GO TO 6 END IF 6 WRITE(NDECC,NFORM)IZC CALL MESSAG(NDECC,NCHAR,XLAB,YLAB) END IF RETURN END C SUBROUTINE CFRAME CHECKS THE TRASMISSION LOSS AGAINST UPPER C AND LOWER LIMITS DEFINED FOR THE PLOT AXES. SUBROUTINE CFRAME(ARRAY,N1,N2,V1,V2,IFLAG) DIMENSION ARRAY(N2) VMIN=AMIN1(V1,V2) VMAX=AMAX1(V1,V2) IF(IFLAG.GT.0) GO TO 6100 DO 6000 I=N1,N2 IF(ARRAY(I).GE.VMAX) GO TO 6000 IF(ARRAY(I).LE.VMIN) GO TO 6000 IFLAG=1 GO TO 6100 6000 CONTINUE RETURN 6100 DO 6200 I=N1,N2 IF(ARRAY(I).GT.VMAX) ARRAY(I)=VMAX IF(ARRAY(I).LT.VMIN) ARRAY(I)=VMIN 6200 CONTINUE RETURN END