C file PCPROF6.FOR
C ----------------------------------------------------------------------!-------
C 24 Mar 2006 - Nothing left
C ----------------------------------------------------------------------!-------
C 24 Mar 2006 - Moved SCLPIC, FULANN, SUPNEG, TITLE, TITLTX, TITLXY, 
C               XTICKS, YTICKS to S8
C 24 Mar 2006 - Moved VMNMX to S7
C 24 Mar 2006 - Moved SCMPLX, SETXY to S6
C 24 Mar 2006 - Changed COMMON block /RAYDEV/
C  1 Mar 2006 - Removed SET2, ISET2
C 27 Feb 2006 - Removed SREAD1, IMOVE, RMOVE, SETSRD, SETUCON, UCON
C 27 Feb 2006 - Removed SFILL, STRIM, SFILTR
C 2 Jun 2004 - Changed A, C, and E in SUBROUTINE TITLE from REAL to CHARACTER*80
C Note: changes marked as "10 Jun 2003" were not made to this file on that date.
C They are the changes in the 10 Jun 2003 version of the raytracing program.
C 10 Jun 2003 - line 38 (SUBROUTINE SET2) ENTRY ISET2 to SUB ISET2 & rewrote
C ----------------------------------------------------------------------!-------
      SUBROUTINE SCMPLX_test
C     SPECIFY USE OF SIMPLEX CHARACTER SET(DISSPLA)
C     WRITE PARAMETERS TO GRAPHICS CALLS FILE
C
c     COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVGRP,NDEVBIN,NDEVTXT ! 24 Mar 2006
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVTXT,NDEVBIN         ! 24 Mar 2006
C
      WRITE(NDEVTXT,100) 10
100   FORMAT(I2)
      END SUBROUTINE SCMPLX_test
C ----------------------------------------------------------------------!-------
      SUBROUTINE SET2_test(A,V,N)
C     SETS N COMPONENTS OF VECTOR 'A' TO SINGLE VALUE V
C

      DOUBLE PRECISION a(n),v
      integer ia(n)

C
      DO 100 I=1,N
100	  A(I)=V
      RETURN
C ----------------------------------------------------------------------!-------
	end SUBROUTINE SET2_test ! 10 Jun 2003, added this and rewrote below
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE ISET2_test(NA,NV,N)
C ----------------------------------------------------------------------!-------
C	ENTRY ISET2(NA,NV,N)
C ----------------------------------------------------------------------!-------
C     SPECIAL ENTRY FOR INTEGER ARRAYS FOR MACHINES HAVING DIFFERENT
C     WORD SIZES FOR INTEGERS THAN REALS.
	INTEGER N,NA(N)
      CHARACTER NV
      DO 200 I=1,N
C200	NA(I) = NV
200   NA(I)=IACHAR(NV)      
C200	continue
c
C ----------------------------------------------------------------------!-------
c      ENTRY ISET2 (IA,IV,N)
C
C     SPECIAL ENTRY FOR INTEGER ARRAYS FOR MACHINES HAVING DIFFERENT
C     WORD SIZES FOR INTEGERS THAN DOUBLE PRECISION.
C
c
c      DO 200 I=1,N
c200	 IA(I) = IV
      RETURN
C ----------------------------------------------------------------------!-------
      END SUBROUTINE ISET2_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE SETXY_test(PROJ,XMIN,YMIN,XMAX,YMAX)
C ----------------------------------------------------------------------!-------
C     PLOT INITIALIZATION; SETS PROJECTION PARAMETERS
C
      COMMON/LABCLT/PROJCT,THMIN,THMAX,RMIN,RMAX
C
C
C   INITIAL ANNOTATION MODEL
      CALL SETANN
C
      PROJCT=PROJ
      THMIN=XMIN
      RMIN=YMIN
      THMAX=XMAX
      RMAX=YMAX
C ----------------------------------------------------------------------!-------
      END SUBROUTINE SETXY_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE FULANN_test
C ----------------------------------------------------------------------!-------
C     ANNOTATION MODEL SUITED FOR PUBLICATION QUALITY LETTERING
C
      implicit double precision (a-h,o-z)

      CHARACTER*(*) S,C
C
C     INITIALIZES PLOT IN PUBLICATION-QUALITY MODE(REQUIRES DISSPLA)
C
C     COMMON DECK "WWR" INSERTED HERE
      PARAMETER (NWARSZ=1000) 
      COMMON/WW/ dum(10), MAXW,W(NWARSZ)
      DOUBLE PRECISION MAXSTP,MAXERR,INTYP,LLAT,LLON
      EQUIVALENCE (EARTHR,W(1)),(RAY,W(2)),(XMTRH,W(3)),(TLAT,W(4)),
     1 (TLON,W(5)),(OW,W(6)),(FBEG,W(7)),(FEND,W(8)),(FSTEP,W(9)),
     2 (AZ1,W(10)),(AZBEG,W(11)),(AZEND,W(12)),(AZSTEP,W(13)),
     3 (BETA,W(14)),(ELBEG,W(15)),(ELEND,W(16)),(ELSTEP,W(17)),
     8   (RUNSUP,W(18)),(RCVRH,W(20)),
     4 (ONLY,W(21)),(HOP,W(22)),(MAXSTP,W(23)),(PLAT,W(24)),(PLON,W(25))
     5,(HMAX,W(26)),(RAYFNC,W(29)),(EXTINC,W(33)),
     6 (HMIN,W(27)),(RGMAX,W(28)),
     8 (INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),
     6 (STEP1,W(44)),(STPMAX,W(45)),(STPMIN,W(46)),(FACTR,W(47)),
     7 (SKIP,W(71)),(RAYSET,W(72)),(PRTSRP,W(74)),(HITLET,W(75))
     9 ,(BINRAY,W(76)),(PAGLN,W(77)),(PLT,W(81)),(PFACTR,W(82)),
     1 (LLAT,W(83)),(LLON,W(84)),(RLAT,W(85)),(RLON,W(86))
     2,(TIC,W(87)),(HB,W(88)),(HT,W(89)),(TICV,W(96))
C     COMMON DECK "ANNOT" INSERTED HERE 
      CHARACTER*10 ANOTES,HNOTES
      COMMON/ANNCTL/LENA(4),LENHA(3)
      COMMON/ANNCTC/ANOTES(2,4),HNOTES(4,3)
C
      INTEGER LHNA(4) ,LHNHA(3)
      CHARACTER*10 AQOTES(2,4),HQOTES(4,3)
C
      DATA LHNA,AQOTES/4*2,'DEPTH (#M!',')','DEPTH (#KM','!)',
     2'HEIGHT (#M','!)','HEIGHT (#K','M!)'/
      DATA LHNHA,HQOTES/3,2,4, 'RANGE AT S','EA LEVEL (','#KM!)',' '
     2       ,'RANGE (#DE','G!)',2*' '
     3       ,'CROSS RANG','E AT SEA L','EVEL (#KM!',')'/
C
      ENTRY SETANN_test
C
      CALL SCMPLX
C
C*****  PUT TRAILING BLANKS ON THE ARGUMENTS SO THAT NO EXTRANEOUS
C       CHARACTERS MAY BE INTRODUCED.  JAH.
C       THE ARGUMENTS ARE CHARACTER*10 IN MX1ALF,MX2ALF.  ESSENTIAL
C       FOR THE CYBER OPERATION.
C
      CALL MX1ALF('STAND     ','!')
      CALL MX2ALF('L/CSTD    ','#')
      CALL HEIGHT(HITLET)
C
      CALL IMOVE(LENA,LHNA,4) 
      CALL IMOVE(LENHA,LHNHA,3)
      DO 10 I=1,2
      DO 10 J=1,4
10    ANOTES(I,J)=AQOTES(I,J) 
      DO 20 I=1,4
      DO 20 J=1,3
20    HNOTES(I,J)=HQOTES(I,J) 
C
      RETURN
C
      ENTRY ANNFIL_test(S,C)
      C=S
C ----------------------------------------------------------------------!-------
      END SUBROUTINE FULANN_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE SREAD1_test (AB,NWOK,NW) ! 27 Feb 2006
C ----------------------------------------------------------------------!-------
C     THIS IS THE FALLTHROUGH FEATURE FOR READW WHEN ENCOUNTERING
C     A NON STANDARD LABELED COMMON BLOCK. SREAD1 WILL ADD TABULAR
C     DATA TO THE DEFAULT GP ARRAY PGP AND INCLUDE INDEX OFFSET
C     VALUES TO A LOOKUP ARRAY 'LIST'.

      implicit double precision (a-h,o-z)

C     COMMON DECK "CPROCFL" INSERTED HERE
      INTEGER PMX,PNTBL,PITBL,PFRMTBL,IDSP(10)
C     PARAMETER DECK "PGROUPS"
      PARAMETER (NCHPG1=11,NWPV=250,NSPGP=NCHPG1+2*NWPV+1)
      PARAMETER (MNGRP=9,MXGRP=69,MXLIST=MXGRP-MNGRP+2)
      COMMON/PROCFL/LIST(MXLIST)
      COMMON/PROCFL/PMX,PNTBL(10),PITBL(10),PFRMTBL(10),PGP(NSPGP)
      EQUIVALENCE (PGP,IDSP)
C
C
      INTEGER PPX    ,PQTBL(10),PLTBL(10),PIRMTBL(10)
C
      DATA PPX/2/
      DATA PQTBL/1,NCHPG1,NSPGP,7*0/
      DATA PLTBL/1,NWPV,8*0/
      DATA PIRMTBL/1,2,8*0/
C
      NWA=IABS(NW)-(MNGRP-2)
      IF(NWA.LT.2 .OR. NWA.GT.MXLIST) then
           PRINT*,'ERROR: Invalid W-ARRAY Value.',NW
           PRINT*,' Value must be >= 2 and <= 62.'
           STOP
      endif
C
      CALL READW1(AB,NWOK,NW,PMX,PNTBL,PITBL,PFRMTBL,PGP)
C
C     UPDATE THE LIST, LIST(1)=MAXIMUM USED ELEMENT
      LIST(1)=MAX0(LIST(1),NWA)
      LIST(NWA)=PNTBL(1)
C
C     GET NEXT NUMERICAL INDEX FROM THE POINTER ARRAY
      NLN=PNTBL(2)
C
C     NUMBER OF VALUES IS INTEGRAL PART OF FIRST ELEMENT
      NPTS=PGP(NLN) 
C     NUMBER OF ROWS IS KEPT AS FRACTIONAL PART
      NELS=(PGP(NLN)-NPTS)*10.+.5
      N2=NPTS/NELS
      NMX=PITBL(2)
C     MAKE ADJUSTMENTS TO LENGTHS AND OFFSETS
      PITBL(2)=NMX-N2-(NCHPG1-1)
      NUP=NPTS+NCHPG1
      PNTBL(1)=PNTBL(1)+NUP
      PNTBL(2)=PNTBL(2)+NUP
      NLN=NLN+1
C
C     LOOP TO MOVE NELS-1 ROWS OF PGP(NMX,NELS) TO PGP(N2,NELS)
C     THUS MAKING PGP A CONTIGUOUS ARRAY
      NTO=NLN+N2
      NFRM=NLN+NMX
      DO 100 I=2,NELS
      IF(NTO.GT.0 .AND. NFRM+N2-1.LE.NSPGP)
     1        CALL RMOVE(PGP(NTO),PGP(NFRM),N2)
      NTO=NTO+N2
100   NFRM=NFRM+NMX 
      RETURN
C
      ENTRY SETSRD_test ! 27 Feb 2006
C***** CHANGED "ISET2" TO "SET2".  SEE SET2 SUBROUTINE.
C*****	CALL SET2(LIST,0,MXLIST)
C***** changed to a loop rather than writing an integer version of SET2
C***** SET2 is for REAL*8.

      do 10 ii = 1,mxlist
10	   list(ii) = 0

      PMX=PPX
      CALL IMOVE(PNTBL,PQTBL,10)
      CALL IMOVE(PITBL,PLTBL,10)
      CALL IMOVE(PFRMTBL,PIRMTBL,10)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE SREAD1_test 
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE TITLE_test(A,B,C,D,E,F,G,H) 
C ----------------------------------------------------------------------!-------
C     DEFINES TITLE, AXES LABELS AND LENGTHS OF PLOTS(DISSPLA)
C     WRITE PARAMETERS TO GRAPHICS CALLS FILE
C

c     COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVGRP,NDEVBIN,NDEVTXT ! 24 Mar 2006
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVTXT,NDEVBIN         ! 24 Mar 2006
C*****THESE 3 ARRAYS NEED TO BE REAL.  IF DECLARED CHAR*40, THE DIRECT
C*****ACCESS READ IN TAPRD WILL CAUSE EXTRA CHARACTERS TO BE PRESENT?!

C      REAL A(4),C(4),E(4) ! 2 Jun 2004
      CHARACTER*80 A,C,E   ! 2 Jun 2004
      integer b,d,f
      DOUBLE PRECISION G,H
C
C*****CHANGED ENTRY TO INCLUDE THE PARAMETER LIST.  MICROSOFT WOULD NOT
C*****COMPILE WITHOUT IT.  JAH.
C
C ----------------------------------------------------------------------!-------
      ENTRY TITLEW_test (A,B,C,D,E,F,G,H)
      WRITE(NDEVTXT,100) 25,G,H
100   FORMAT(I2,2F6.2)
      CALL TITLTX (A,B)
      CALL TITLTX (C,D)
      CALL TITLTX (E,F)
C
C ----------------------------------------------------------------------!-------
      END SUBROUTINE TITLE_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE TITLXY_test(I,J,K,L,M,N,XAXIS,YAXIS)
C ----------------------------------------------------------------------!-------
C
      implicit double precision (a-h,o-z)

      CHARACTER I*(*),K*(*),M*(*),CD*80 
      PARAMETER (NWARSZ=1000) 
      COMMON/WW/ dum(10), MAXW,W(NWARSZ)
      EQUIVALENCE (HITLET,W(75))
C
      F=1.0
C.....Changed from 6.65 inches. Too big for 8.5x11
      XAXIS=5.0

C.....Changed from 6.8.
      YAXIS=5.11

      IF(J.GT.0) GO TO 50
      F=.8
      XAXIS=9.0
      YAXIS=6.0
C
50    continue
ccccc      CALL PHYSOR(2.0,1.66)  already called by PLOTINI
      CALL NOBRDR
      IF(HITLET.LE.0.0) CALL HEIGHT(F*0.4)
ccccc      CALL SCLPIC(1.4)   already called by PLOTINI
      CALL TITLEW(CD(I),J,CD(K),L,CD(M),N,XAXIS,YAXIS)
      RETURN
C ----------------------------------------------------------------------!-------
      END SUBROUTINE TITLXY_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      LOGICAL FUNCTION UCON_test (JC1,U,CONV) ! 27 Feb 2006
C ----------------------------------------------------------------------!-------

      implicit double precision (a-h,o-z)

C     PROVIDES KEYWORD UNITS CONVERSION FOR W-ARRAY INPUT.
C     UNITS SPECIFICATION MUST BE IN THE FORM 'DV UN' WHERE DV IS THE 
C     TYPE OF VARIABLE(SUCH AS AN FOR ANGLE) AND UN IS THE UNITS CHOICE
C     SUCH AS RD FOR RADIANS). RETURN VALUE IS THE CONVERSION FACTOR.

C     COMMON DECK "CUCON" INSERTED HERE
      COMMON/UCONV/CNVV(5,4)
      CHARACTER PCV*3,CNVC*2
      COMMON/UCONC/PCV(5),CNVC(5,4)
C     COMMON DECK "CONST" INSERTED HERE 
      COMMON/PCONST/CREF,RGAS,GAMMA
      COMMON/MCONST/PI,PIT2,PID2,DEGS,RAD,ALN10
C     COMMON DECK "WWR" INSERTED HERE
      PARAMETER (NWARSZ=1000) 
      COMMON/WW/ dum(10), MAXW,W(NWARSZ)
      DOUBLE PRECISION MAXSTP,MAXERR,INTYP,LLAT,LLON
      EQUIVALENCE (EARTHR,W(1)),(RAY,W(2)),(XMTRH,W(3)),(TLAT,W(4)),
     1 (TLON,W(5)),(OW,W(6)),(FBEG,W(7)),(FEND,W(8)),(FSTEP,W(9)),
     2 (AZ1,W(10)),(AZBEG,W(11)),(AZEND,W(12)),(AZSTEP,W(13)),
     3 (BETA,W(14)),(ELBEG,W(15)),(ELEND,W(16)),(ELSTEP,W(17)),
     8   (RUNSUP,W(18)),(RCVRH,W(20)),
     4 (ONLY,W(21)),(HOP,W(22)),(MAXSTP,W(23)),(PLAT,W(24)),(PLON,W(25))
     5,(HMAX,W(26)),(RAYFNC,W(29)),(EXTINC,W(33)),
     6 (HMIN,W(27)),(RGMAX,W(28)),
     8 (INTYP,W(41)),(MAXERR,W(42)),(ERATIO,W(43)),
     6 (STEP1,W(44)),(STPMAX,W(45)),(STPMIN,W(46)),(FACTR,W(47)),
     7 (SKIP,W(71)),(RAYSET,W(72)),(PRTSRP,W(74)),(HITLET,W(75))
     9 ,(BINRAY,W(76)),(PAGLN,W(77)),(PLT,W(81)),(PFACTR,W(82)),
     1 (LLAT,W(83)),(LLON,W(84)),(RLAT,W(85)),(RLON,W(86))
     2,(TIC,W(87)),(HB,W(88)),(HT,W(89)),(TICV,W(96))
      CHARACTER U*(*),PU*3,PV*2
C
      DATA NPV,NPU/5,4/
      UCON=.FALSE.
      CONV=1.0
C
      READ(U,100) PU,PV
100   FORMAT(A,A)
C
      DO 2010 J=1,NPV
2010     IF(PU.EQ.PCV(J)) GO TO 2015
      JC1=4
      RETURN
2015  JC1=J
      DO 2020 K=1,NPU
2020     IF(PV.EQ.CNVC(J,K)) GO TO 2025 
      JC1=4
      RETURN
2025  UCON=.TRUE.
      CONV=CNVV(JC1,K)
      IF(CONV.EQ.-1.0) CONV=1.0/EARTHR
      RETURN
C
C ----------------------------------------------------------------------!-------
      END FUNCTION UCON_test 
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      Subroutine SETUCON_test ! 27 Feb 2006
C ----------------------------------------------------------------------!-------

      implicit double precision (a-h,o-z)

C     COMMON DECK "CUCON" INSERTED HERE
      COMMON/UCONV/CNVV(5,4)
      CHARACTER PCV*3,CNVC*2
      COMMON/UCONC/PCV(5),CNVC(5,4)
C     COMMON DECK "CONST" INSERTED HERE 
      COMMON/MCONST/PI,PIT2,PID2,DEGS,RAD,ALN10
C
C     INITIAL CONVERSION CONSTANTS
C
      CNVV(1,2) = RAD
C     USE TAG -1 FOR DYNAMIC USE OF EARTHR
      CNVV(1,3) = -1.0
      CNVV(2,2) = 1.0E-3
      CNVV(2,3) = 3.048006096E-4
      CNVV(2,4) = 1.852
      CNVV(3,2) = PIT2
      CNVV(3,3) = PIT2*1.0E3
      CNVV(3,4) = -PIT2
      CNVV(4,1) = 1.0/4.3429448

      RETURN
C ----------------------------------------------------------------------!-------
      END Subroutine SETUCON_test 
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE TITLTX_test (ACHAR,B)
C ----------------------------------------------------------------------!-------
C     THIS IS CALLED BY TITLE IN ORDER TO WRITE TO NDEVTXT.
C
c     COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVGRP,NDEVBIN,NDEVTXT ! 24 Mar 2006
      COMMON/RAYDEV/NRYIND,NDEVTMP,NFRMAT,NDEVTXT,NDEVBIN         ! 24 Mar 2006
      CHARACTER*40 ACHAR
      LOGICAL FOUND
      INTEGER B
C
      NMBLK=0
      FOUND = .FALSE.

      DO 10 I=40,1,-1
         IF (.NOT.FOUND) THEN
            IF(ACHAR(I:I).EQ.' ') NMBLK=NMBLK+1
            IF(ACHAR(I:I).EQ.'$') FOUND = .TRUE.
         ENDIF
10    CONTINUE
      LENA = 40-NMBLK
C
      WRITE(NDEVTXT,200) B,(ACHAR(I:I),I=1,LENA)
200   FORMAT(I5,1X,40A1)
C
C ----------------------------------------------------------------------!-------
      END SUBROUTINE TITLTX_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE IMOVE_test(JOUT,INPI,N) ! 27 Feb 2006
C ----------------------------------------------------------------------!-------
C     THIS ROUTINE REPLACES THE ENTRY POINT THAT WAS PART OF DFSYS. JAH.
C     THIS IS MACHINE INDEPENDENT AND THUS DOES NOT NEED TO BE PART OF
C     OF DFSYS.

      INTEGER INPI(*), JOUT(*),N

      DO 10 I=1,N
10    JOUT(I) = INPI(I)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE IMOVE_test
C ----------------------------------------------------------------------!-------
C ----------------------------------------------------------------------!-------
      SUBROUTINE RMOVE_test(ROUT,RINP,N) ! 27 Feb 2006
C ----------------------------------------------------------------------!-------
C     THIS ROUTINE REPLACES THE ENTRY POINT THAT WAS PART OF DFSYS. JAH.
  
      DOUBLE PRECISION RINP(*), ROUT(*)
      INTEGER N
  
      DO 10 I=1,N
10    ROUT(I) = RINP(I)
C ----------------------------------------------------------------------!-------
      END SUBROUTINE RMOVE_test
C ----------------------------------------------------------------------!-------
