c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                       .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c ... visgeo.f
c
c     contains documentation and code for subroutine visgeo
c
      SUBROUTINE DVISGEO(M,IDP,JDP,X,Y,Z,H,EYER,EYELAT,EYELON,WORK,
     +                  LWORK,IWORK,LIWORK,IERROR)
      DOUBLE PRECISION X
      DOUBLE PRECISION Y
      DOUBLE PRECISION Z
      DOUBLE PRECISION H
      DOUBLE PRECISION EYER
      DOUBLE PRECISION EYELAT
      DOUBLE PRECISION EYELON
      DOUBLE PRECISION WORK
c
c     subroutine visgeo will display a function on the sphere
c     as a solid. ie. as a "lumpy" sphere. visgeo calls subroutine
c     vsurf to produce the visible surface rendering. X, Y, and Z
c     are the points on an icosahedral geodesic computed by
c     subroutine geopts available in spherepack.
c
c     requires routines visgeo1 ctos stoc vsurf vsurf1
c                       prjct box
c
c     visgeo uses the ncar graphics package.
c     compile with: ncargf77 (all programs above)
c
c     execute with:  a.out
c
c     on screen display with:  ctrans -d x11 gmeta
c
c     print with:  ctrans -d ps.color gmeta > gmeta.ps
c                  lpr -P(your printer) gmeta.ps
c
c
c     input parameters
c
c     m        the number of points on one edge of the icosahedron
c
c     idp,jdp  the first and second dimensions of the three
c              dimensional arrays x, y, z, and h.
c
c     x,y,z    the coordinates of the geodesic points on
c              the unit sphere computed by subroutine geopts.
c              the indices are defined on the unfolded
c              icosahedron as follows for the case m=3
c
c                north pole
c
c                 (5,1)          0      l
c        i     (4,1) (5,2)              a    (repeated for
c           (3,1) (4,2) (5,3)  theta1   t    k=2,3,4,5 in
c        (2,1) (3,2) (4,3)              i        -->
c     (1,1) (2,2) (3,3)        theta2   t    the longitudinal
c        (1,2) (2,3)                    u    direction)
c           (1,3)                pi     d
c      j                                e
c         south pole
c
c            total number of vertices is  10*(m-1)**2+2
c            total number of triangles is 20*(m-1)**2
c
c     h      a three dimensional array that contains the discrete
c            function to be displayed. h(i,j,k) is the distance from
c            the center of the sphere to the "lumpy" surface at the
c             point [x(i,j,k),y(i,j,k),z(i,j,k)] on the unit sphere.
c
c     eyer   the distance from the center of the sphere to the eye.
c
c     eyelat the colatitudinal coordinate of the eye (in degrees).
c
c     eyelon the longitudinal  coordinate of the eye (in degrees).
c
c     idp    the first dimension of the array h as it appears in
c            the program that calls visgeo
c
c     jdp    the second dimension of the array h as it appears in
c            the program that calls visgeo
c
c     work   a real work array
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls visgeo. lwork must be at least
c                       480*(m-1)**2.
c
c     iwork  an integer work array
c
c     liwork the dimension of the array iwork as it appears in the
c            program that calls visgeo. liwork must be at least
c                       140*(m-1)**2.
c
c     input parameter
c
c     ierror = 0    no error
c            = 1    h(i,j,k) is less than zero for some i,j,k.
c            = 2    eyer is less than h(i,j,k) for some i,k,k.
c            = 3    lwork  is less than 480*(m-1)**2
c            = 4    liwork is less than 140*(m-1)**2
c
      DIMENSION H(IDP,JDP,5),X(IDP,JDP,5),Y(IDP,JDP,5),Z(IDP,JDP,5),
     +          WORK(*)
      INTEGER IWORK(*)

      MMSQ = (M-1)**2
      IERROR = 3
      IF (LWORK.LT.480*MMSQ) RETURN
      IERROR = 4
      IF (LIWORK.LT.140*MMSQ) RETURN
      DO 10 K = 1,5
          DO 10 J = 1,M
              DO 10 I = 1,M + M - 1
                  IF (H(I,J,K).GE.0.D0) GO TO 15
                  IERROR = 1
                  RETURN
   15             IF (EYER.GT.H(I,J,K)) GO TO 10
                  IERROR = 2
                  RETURN
   10 CONTINUE
      IERROR = 0
      LT = 20* (M-1)**2
      LG = 5*M* (M+M-1)
      I1 = 1
      I2 = I1 + LT
      I3 = I2 + LT
      I4 = I3 + LT
      I5 = I4 + LT
      I6 = I5 + LT
      I7 = I6 + LT
      I8 = I7 + LT
      I9 = I8 + LT
      I10 = I9 + LT
      I11 = I10 + LT
      I12 = I11
      I13 = I12 + LG
      I14 = I13 + LG
      CALL DVISGEO1(M,IDP,JDP,H,EYER,EYELAT,EYELON,X,Y,Z,WORK(I1),
     +             WORK(I2),WORK(I3),WORK(I4),WORK(I5),WORK(I6),
     +             WORK(I7),WORK(I8),WORK(I9),IWORK(1),WORK(I11),
     +             WORK(I12),WORK(I13),WORK(I14),IWORK(LT+1))
      RETURN
      END
      SUBROUTINE DVISGEO1(M,IDP,JDP,H,EYER,EYELAT,EYELON,XI,YI,ZI,X1,
     +                    Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,ITYPE,WORK,X,Y,Z,
     +                    IWORK)
      DOUBLE PRECISION H
      DOUBLE PRECISION EYER
      DOUBLE PRECISION EYELAT
      DOUBLE PRECISION EYELON
      DOUBLE PRECISION XI
      DOUBLE PRECISION YI
      DOUBLE PRECISION ZI
      DOUBLE PRECISION X1
      DOUBLE PRECISION Y1
      DOUBLE PRECISION Z1
      DOUBLE PRECISION X2
      DOUBLE PRECISION Y2
      DOUBLE PRECISION Z2
      DOUBLE PRECISION X3
      DOUBLE PRECISION Y3
      DOUBLE PRECISION Z3
      DOUBLE PRECISION WORK
      DOUBLE PRECISION X
      DOUBLE PRECISION Y
      DOUBLE PRECISION Z
      DOUBLE PRECISION RAD
      DOUBLE PRECISION THETA
      DOUBLE PRECISION ELAMBDA
      DOUBLE PRECISION PI
      DOUBLE PRECISION DTR
      DOUBLE PRECISION XEYE
      DOUBLE PRECISION YEYE
      DOUBLE PRECISION ZEYE
      DIMENSION H(IDP,JDP,5),XI(IDP,JDP,5),YI(IDP,JDP,5),ZI(IDP,JDP,5),
     +          X1(*),Y1(*),Z1(*),X2(*),Y2(*),Z2(*),X3(*),Y3(*),Z3(*),
     +          ITYPE(*),WORK(*),X(M+M-1,M,5),Y(M+M-1,M,5),Z(M+M-1,M,5)
      INTEGER IWORK(*)
c
c     the * above refers to 20*(m-1)**2 locations which is the
c     number of triangles
c
      DO 10 K = 1,5
          DO 10 J = 1,M
              DO 10 I = 1,M + M - 1
                  CALL DCTOS(XI(I,J,K),YI(I,J,K),ZI(I,J,K),RAD,THETA,
     +                      ELAMBDA)
                  CALL DSTOC(H(I,J,K),THETA,ELAMBDA,X(I,J,K),Y(I,J,K),
     +                      Z(I,J,K))
   10 CONTINUE
      NTRI = 0
      DO 20 K = 1,5
          DO 20 J = 1,M - 1
              DO 20 I = 1,M + M - 2
                  NTRI = NTRI + 1
                  X1(NTRI) = X(I,J,K)
                  Y1(NTRI) = Y(I,J,K)
                  Z1(NTRI) = Z(I,J,K)
                  X2(NTRI) = X(I+1,J+1,K)
                  Y2(NTRI) = Y(I+1,J+1,K)
                  Z2(NTRI) = Z(I+1,J+1,K)
                  X3(NTRI) = X(I+1,J,K)
                  Y3(NTRI) = Y(I+1,J,K)
                  Z3(NTRI) = Z(I+1,J,K)
                  ITYPE(NTRI) = 13
                  NTRI = NTRI + 1
                  X1(NTRI) = X(I,J,K)
                  Y1(NTRI) = Y(I,J,K)
                  Z1(NTRI) = Z(I,J,K)
                  X2(NTRI) = X(I+1,J+1,K)
                  Y2(NTRI) = Y(I+1,J+1,K)
                  Z2(NTRI) = Z(I+1,J+1,K)
                  X3(NTRI) = X(I,J+1,K)
                  Y3(NTRI) = Y(I,J+1,K)
                  Z3(NTRI) = Z(I,J+1,K)
                  ITYPE(NTRI) = 3
   20 CONTINUE
c      write(6,22) ntri
   22 FORMAT (i10)
c      write(6,23) (x1(l2),y1(l2),z1(l2),x2(l2),y2(l2),z2(l2),
c     1             x3(l2),y3(l2),z3(l2),l2=1,ntri)
c 23   format(9f10.7)
c
      PI = 4.D0*ATAN(1.D0)
      DTR = PI/180.D0
      XEYE = EYER*SIN(DTR*EYELAT)
      YEYE = XEYE*SIN(DTR*EYELON)
      XEYE = XEYE*COS(DTR*EYELON)
      ZEYE = EYER*COS(DTR*EYELAT)
      CALL DVSURF(XEYE,YEYE,ZEYE,NTRI,X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,ITYPE,
     +           WORK,IWORK)
      RETURN
      END
      SUBROUTINE DCTOS(X,Y,Z,R,THETA,PHI)
      DOUBLE PRECISION X
      DOUBLE PRECISION Y
      DOUBLE PRECISION Z
      DOUBLE PRECISION R
      DOUBLE PRECISION THETA
      DOUBLE PRECISION PHI
      DOUBLE PRECISION R1

      R1 = X*X + Y*Y
      IF (R1.NE.0.D0) GO TO 10
      PHI = 0.D0
      THETA = 0.D0
      IF (Z.LT.0.D0) THETA = 4.D0*ATAN(1.D0)
      RETURN
   10 R = SQRT(R1+Z*Z)
      R1 = SQRT(R1)
      PHI = ATAN2(Y,X)
      THETA = ATAN2(R1,Z)
      RETURN
      END
      SUBROUTINE DSTOC(R,THETA,PHI,X,Y,Z)
      DOUBLE PRECISION R
      DOUBLE PRECISION THETA
      DOUBLE PRECISION PHI
      DOUBLE PRECISION X
      DOUBLE PRECISION Y
      DOUBLE PRECISION Z
      DOUBLE PRECISION ST

      ST = SIN(THETA)
      X = R*ST*COS(PHI)
      Y = R*ST*SIN(PHI)
      Z = R*COS(THETA)
      RETURN
      END
      SUBROUTINE DVSURF(XEYE,YEYE,ZEYE,NTRI,X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,
     +                 ITYPE,WORK,IWORK)
      DOUBLE PRECISION XEYE
      DOUBLE PRECISION YEYE
      DOUBLE PRECISION ZEYE
      DOUBLE PRECISION X1
      DOUBLE PRECISION Y1
      DOUBLE PRECISION Z1
      DOUBLE PRECISION X2
      DOUBLE PRECISION Y2
      DOUBLE PRECISION Z2
      DOUBLE PRECISION X3
      DOUBLE PRECISION Y3
      DOUBLE PRECISION Z3
      DOUBLE PRECISION WORK
c
c    subroutine vsurf is like subroutine hidel except the triangles
c    are categorized. vsurf is also like solid except triangles rather
c    than lines are covered.
c
c     written by paul n. swarztrauber, national center for atmospheric
c     research, p.o. box 3000, boulder, colorado, 80307
c
c    this program plots visible lines for the surface defined
c    by the input 3-d triangles with corners at (x1,y1,z1), (x2,y2,z2)
c    and (x3,y3,z3). the sides of these these triangles may or
c    may not be plotted depending on itype. if itype is 1 then the
c    side between points (x1,y1,z1) and (x2,y2,z2) is plotted if it
c    is visible. if itype is 2 then the side between (x2,y2,z2)
c    and (x3,y3,z3) is plotted. if itype is 3 then the visible portion
c    of the side between (x3,y3,z3) and (x1,y1,z1) is plotted.
c    any combination is possible by specifying itype to be one
c    of the following values: 0,1,2,3,12,13,23,123.
c
c    the length of real    array  work must be at least 14*ntri
c
c    the length of integer array iwork must be at least  6*ntri
c
c
c    the vertices of the triangles are renumbered by vsurf so that
c    their projections are orientated counterclockwise. the user need
c    only be aware that the vertices may be renumbered by vsurf.
c
      DIMENSION X1(NTRI),Y1(NTRI),Z1(NTRI),X2(NTRI),Y2(NTRI),Z2(NTRI),
     +          X3(NTRI),Y3(NTRI),Z3(NTRI),ITYPE(NTRI),WORK(14*NTRI)
      INTEGER IWORK(6*NTRI)
c
      CALL DVSURF1(XEYE,YEYE,ZEYE,NTRI,X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,
     +             ITYPE,WORK,WORK(NTRI+1),WORK(2*NTRI+1),
     +             WORK(3*NTRI+1),WORK(4*NTRI+1),WORK(5*NTRI+1),
     +             WORK(6*NTRI+1),WORK(7*NTRI+1),WORK(8*NTRI+1),
     +             WORK(9*NTRI+1),WORK(10*NTRI+1),WORK(11*NTRI+1),
     +             WORK(12*NTRI+1),WORK(13*NTRI+1),IWORK,
     +             IWORK(NTRI+1),IWORK(2*NTRI+1),IWORK(4*NTRI+1))
      RETURN
      END
      SUBROUTINE DVSURF1(XEYE,YEYE,ZEYE,NTRI,X1,Y1,Z1,X2,Y2,Z2,X3,Y3,
     +                   Z3,ITYPE,PX1,PY1,PX2,PY2,PX3,PY3,VX1,VY1,VX2,
     +                   VY2,VX3,VY3,TL,TR,KH,NEXT,ISTART,IFINAL)
      DOUBLE PRECISION XEYE
      DOUBLE PRECISION YEYE
      DOUBLE PRECISION ZEYE
      DOUBLE PRECISION X1
      DOUBLE PRECISION Y1
      DOUBLE PRECISION Z1
      DOUBLE PRECISION X2
      DOUBLE PRECISION Y2
      DOUBLE PRECISION Z2
      DOUBLE PRECISION X3
      DOUBLE PRECISION Y3
      DOUBLE PRECISION Z3
      DOUBLE PRECISION PX1
      DOUBLE PRECISION PY1
      DOUBLE PRECISION PX2
      DOUBLE PRECISION PY2
      DOUBLE PRECISION PX3
      DOUBLE PRECISION PY3
      DOUBLE PRECISION VX1
      DOUBLE PRECISION VY1
      DOUBLE PRECISION VX2
      DOUBLE PRECISION VY2
      DOUBLE PRECISION VX3
      DOUBLE PRECISION VY3
      DOUBLE PRECISION TL
      DOUBLE PRECISION TR
      DOUBLE PRECISION FNTRI
      DOUBLE PRECISION X
      DOUBLE PRECISION Y
      DOUBLE PRECISION Z
      DOUBLE PRECISION DUM1
      DOUBLE PRECISION DUM2
      DOUBLE PRECISION CPROD
      DOUBLE PRECISION PX1H
      DOUBLE PRECISION PY1H
      DOUBLE PRECISION X1HOLD
      DOUBLE PRECISION Y1HOLD
      DOUBLE PRECISION Z1HOLD
      DOUBLE PRECISION PMAX
      DOUBLE PRECISION PMIN
      DOUBLE PRECISION XMIN
      DOUBLE PRECISION XMAX
      DOUBLE PRECISION YMIN
      DOUBLE PRECISION YMAX
      DOUBLE PRECISION DMX
      DOUBLE PRECISION DMY
      DOUBLE PRECISION C
      DOUBLE PRECISION D
      DOUBLE PRECISION XMID
      DOUBLE PRECISION HDY
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION YMID
      DOUBLE PRECISION HDX
      DOUBLE PRECISION HGR
      DOUBLE PRECISION DXT
      DOUBLE PRECISION HR
      DOUBLE PRECISION TL1
      DOUBLE PRECISION TL2
      DOUBLE PRECISION PX4
      DOUBLE PRECISION PY4
      DOUBLE PRECISION PX5
      DOUBLE PRECISION PY5
      DOUBLE PRECISION X4
      DOUBLE PRECISION Y4
      DOUBLE PRECISION Z4
      DOUBLE PRECISION X5
      DOUBLE PRECISION Y5
      DOUBLE PRECISION Z5
      DOUBLE PRECISION X54
      DOUBLE PRECISION Y54
      DOUBLE PRECISION C17
      DOUBLE PRECISION C27
      DOUBLE PRECISION C37
      DOUBLE PRECISION C14
      DOUBLE PRECISION C25
      DOUBLE PRECISION C36
      DOUBLE PRECISION TMIN
      DOUBLE PRECISION TMAX
      DOUBLE PRECISION XPL
      DOUBLE PRECISION YPL
      DOUBLE PRECISION ZPL
      DOUBLE PRECISION XPR
      DOUBLE PRECISION YPR
      DOUBLE PRECISION ZPR
      DOUBLE PRECISION VX1T
      DOUBLE PRECISION VY1T
      DOUBLE PRECISION VZ1T
      DOUBLE PRECISION VX2T
      DOUBLE PRECISION VY2T
      DOUBLE PRECISION VZ2T
      DOUBLE PRECISION APL
      DOUBLE PRECISION BPL
      DOUBLE PRECISION CPL
      DOUBLE PRECISION DPL
      DOUBLE PRECISION VX3T
      DOUBLE PRECISION VY3T
      DOUBLE PRECISION VZ3T
      DOUBLE PRECISION DEN
      DOUBLE PRECISION TIL
      DOUBLE PRECISION TIR
      DOUBLE PRECISION TIM
      DOUBLE PRECISION THOLD
      DOUBLE PRECISION TLH
      DOUBLE PRECISION TRH
      DOUBLE PRECISION XA
      DOUBLE PRECISION YA
      DOUBLE PRECISION XB
      DOUBLE PRECISION YB
c
      DIMENSION X1(NTRI),Y1(NTRI),Z1(NTRI),X2(NTRI),Y2(NTRI),Z2(NTRI),
     +          X3(NTRI),Y3(NTRI),Z3(NTRI),ITYPE(NTRI),PX1(NTRI),
     +          PY1(NTRI),PX2(NTRI),PY2(NTRI),PX3(NTRI),PY3(NTRI),
     +          VX1(NTRI),VY1(NTRI),VX2(NTRI),VY2(NTRI),VX3(NTRI),
     +          VY3(NTRI),TL(NTRI),TR(NTRI),NEXT(NTRI),KH(NTRI),
     +          ISTART(2*NTRI),IFINAL(2*NTRI),LTP(3),IRD(11),IP2(11),
     +          NCT(11),NCV(11),LAST(11)
c
      DOUBLE PRECISION L2E
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION LE2
C*PT*WARNING* Constant already double-precision
c
c     compute projections of 3-d points
c
      LE2 = .6931471805599453094172321d0
C*PT*WARNING* Constant already double-precision
      L2E = 1.d0/LE2
      FNTRI = NTRI
      IRMAX = .5D0*L2E*LOG(FNTRI)
      IRMAX = MIN(IRMAX,10)
      IRMP1 = IRMAX + 1
      DO 4 ICV = 1,11
          NCV(ICV) = 0
    4 CONTINUE
      NCT(1) = 0
      IP2(1) = 1
      IRD(1) = 0
      ISIZE = 4
      DO 7 IRP1 = 2,IRMP1
          IR = IRP1 - 1
          NCT(IRP1) = 0
          IP2(IRP1) = 2**IR
          IRD(IRP1) = IRD(IR) + ISIZE
          ISIZE = (IP2(IRP1)+1)**2
    7 CONTINUE
      ISXM = IRD(IRMP1) + ISIZE + 1
      DO 8 ISX = 1,ISXM
          ISTART(ISX) = 0
          IFINAL(ISX) = 0
    8 CONTINUE
      DO 6 I = 1,NTRI
          NEXT(I) = 0
    6 CONTINUE
      CALL DPRJCT(0,XEYE,YEYE,ZEYE,X,Y,Z,DUM1,DUM2)
c      write(6,127) ntri
  127 FORMAT (' ntri in hidel',i5)
      DO 86 K = 1,NTRI
          CALL DPRJCT(1,XEYE,YEYE,ZEYE,X1(K),Y1(K),Z1(K),PX1(K),PY1(K))
          CALL DPRJCT(1,XEYE,YEYE,ZEYE,X2(K),Y2(K),Z2(K),PX2(K),PY2(K))
          CALL DPRJCT(1,XEYE,YEYE,ZEYE,X3(K),Y3(K),Z3(K),PX3(K),PY3(K))
          IF (K.LT.3) THEN
c          write(6,333) xeye,yeye,zeye,x1(k),y1(k),z1(k),px1(k),py1(k)
  333         FORMAT (' xeye, etc.',8D8.1)
          END IF
   86 CONTINUE
c
c     orientate triangles counter clockwise
c
      DO 70 K = 1,NTRI
          CPROD = (PX2(K)-PX1(K))* (PY3(K)-PY1(K)) -
     +            (PY2(K)-PY1(K))* (PX3(K)-PX1(K))
c      if(cprod.eq.0.) write(6,79) k,px1(k),px2(k),px3(k),
c     -                              py1(k),py2(k),py3(k)
   79     FORMAT ('  cprod=0 at k=',i5,6D9.2)
          IF (CPROD.GE.0.D0) GO TO 70
          PX1H = PX1(K)
          PY1H = PY1(K)
          PX1(K) = PX2(K)
          PY1(K) = PY2(K)
          PX2(K) = PX1H
          PY2(K) = PY1H
          X1HOLD = X1(K)
          Y1HOLD = Y1(K)
          Z1HOLD = Z1(K)
          X1(K) = X2(K)
          Y1(K) = Y2(K)
          Z1(K) = Z2(K)
          X2(K) = X1HOLD
          Y2(K) = Y1HOLD
          Z2(K) = Z1HOLD
          ITYP = ITYPE(K)
          IF (ITYP.EQ.2) ITYPE(K) = 3
          IF (ITYP.EQ.3) ITYPE(K) = 2
          IF (ITYP.EQ.12) ITYPE(K) = 13
          IF (ITYP.EQ.13) ITYPE(K) = 12
   70 CONTINUE
c
c     set screen limits
c
      PMAX = PX1(1)
      PMIN = PX1(1)
      DO 87 K = 1,NTRI
          PMIN = DMIN1(PMIN,PX1(K),PY1(K),PX2(K),PY2(K),PX3(K),PY3(K))
          PMAX = DMAX1(PMAX,PX1(K),PY1(K),PX2(K),PY2(K),PX3(K),PY3(K))
   87 CONTINUE
      PMIN = 1.1D0*PMIN
      PMAX = 1.1D0*PMAX
      CALL SET(0.D0,1.D0,0.D0,1.D0,PMIN,PMAX,PMIN,PMAX,1)
      XMIN = DMIN1(PX1(1),PX2(1),PX3(1))
      XMAX = DMAX1(PX1(1),PX2(1),PX3(1))
      YMIN = DMIN1(PY1(1),PY2(1),PY3(1))
      YMAX = DMAX1(PY1(1),PY2(1),PY3(1))
      DO 1 I = 2,NTRI
          XMIN = DMIN1(XMIN,PX1(I),PX2(I),PX3(I))
          XMAX = DMAX1(XMAX,PX1(I),PX2(I),PX3(I))
          YMIN = DMIN1(YMIN,PY1(I),PY2(I),PY3(I))
          YMAX = DMAX1(YMAX,PY1(I),PY2(I),PY3(I))
    1 CONTINUE
      DMX = XMAX - XMIN
      DMY = YMAX - YMIN
      IF (DMX.GT.DMY) GO TO 2
      C = YMIN
      D = YMAX
      XMID = .5D0* (XMIN+XMAX)
      HDY = .5D0*DMY
      A = XMID - HDY
      B = XMID + HDY
      GO TO 3
    2 A = XMIN
      B = XMAX
      YMID = .5D0* (YMIN+YMAX)
      HDX = .5D0*DMX
      C = YMID - HDX
      D = YMID + HDX
    3 HGR = B - A
c
c     categorize triangles
c
      DO 100 I = 1,NTRI
          XMIN = DMIN1(PX1(I),PX2(I),PX3(I))
          XMAX = DMAX1(PX1(I),PX2(I),PX3(I))
          YMIN = DMIN1(PY1(I),PY2(I),PY3(I))
          YMAX = DMAX1(PY1(I),PY2(I),PY3(I))
          DXT = DMAX1(XMAX-XMIN,YMAX-YMIN)
          IF (DXT.GT.0.D0) GO TO 10
          IR = IRMAX
          GO TO 20
   10     IR = L2E*LOG(HGR/DXT)
          IR = MIN(IR,IRMAX)
   20     IRP1 = IR + 1
          NCT(IRP1) = NCT(IRP1) + 1
          HR = HGR/IP2(IRP1)
          XMID = .5D0* (XMIN+XMAX)
          ID = (XMID-A)/HR + 1.5D0
          YMID = .5D0* (YMIN+YMAX)
          JD = (YMID-C)/HR + 1.5D0
          IJD = IP2(IRP1) + 1
          ISX = ID + (JD-1)*IJD + IRD(IRP1)
          IFX = IFINAL(ISX)
          IF (IFX.GT.0) GO TO 50
          ISTART(ISX) = I
          GO TO 60
   50     NEXT(IFX) = I
   60     IFINAL(ISX) = I
  100 CONTINUE
c      write(6,106) tcat,(irp1,nct(irp1),irp1=1,irmp1)
  106 FORMAT (' time to categorize   ',D15.6,/, (' ir+1',i3,' ntri',i7))
c
c     sort triangles into boxes
c
      L = 0
      DO 30 IRP1 = 1,IRMP1
          IF (NCT(IRP1).EQ.0) GO TO 30
          IST = IRD(IRP1) + 1
          ISD = IP2(IRP1) + 1
          CALL DBOX(ISD,ISTART(IST),NEXT,L,IFINAL)
          LAST(IRP1) = L + 1
   30 CONTINUE
      DO 35 IRP1 = 1,IRMP1
          IL = IRD(IRP1) + (IP2(IRP1)+1)**2 + 1
          IF (ISTART(IL).EQ.0) ISTART(IL) = LAST(IRP1)
   35 CONTINUE
c      write(6,31) tsort,l,ntri
   31 FORMAT (' time to sort  ',D15.6,'   l',i8,'   ntri',i8)
      DO 90 K = 1,NTRI
          VX1(K) = PX2(K) - PX1(K)
          VY1(K) = PY2(K) - PY1(K)
          VX2(K) = PX3(K) - PX2(K)
          VY2(K) = PY3(K) - PY2(K)
          VX3(K) = PX1(K) - PX3(K)
          VY3(K) = PY1(K) - PY3(K)
   90 CONTINUE
      TL1 = 0.D0
      TL2 = 0.D0
      MAXS = 0
      DO 500 IR2 = 1,IRMP1
          IF (NCT(IR2).EQ.0) GO TO 500
          IST = IRD(IR2)
          ISD = IP2(IR2) + 1
          DO 490 J2 = 1,ISD
              DO 480 I2 = 1,ISD
                  IST = IST + 1
                  LS = ISTART(IST)
                  LF = ISTART(IST+1) - 1
                  IF (LF.LT.LS) GO TO 480
c
c     define coverings
c
                  KCV = 0
                  I2M = I2 - 1
                  J2M = J2 - 1
                  DO 300 IR1 = 1,IRMP1
                      IF (NCT(IR1).EQ.0) GO TO 300
                      IF (IR1.GE.IR2) GO TO 260
                      IRDP = 2** (IR2-IR1)
                      I1S = (I2M-1)/IRDP
                      I1F = (I2M+1)/IRDP
                      IF = I2M + 1 - I1F*IRDP
                      IF (IF.GT.0) I1F = I1F + 1
                      J1S = (J2M-1)/IRDP
                      J1F = (J2M+1)/IRDP
                      JF = J2M + 1 - J1F*IRDP
                      IF (JF.GT.0) J1F = J1F + 1
                      GO TO 270
  260                 IRDP = 2** (IR1-IR2)
                      I1S = IRDP* (I2M-1)
                      I1F = IRDP* (I2M+1)
                      J1S = IRDP* (J2M-1)
                      J1F = IRDP* (J2M+1)
  270                 IJD = IP2(IR1) + 1
                      I1S = MAX(I1S+1,1)
                      I1F = MIN(I1F+1,IJD)
                      J1S = MAX(J1S+1,1)
                      J1F = MIN(J1F+1,IJD)
                      IXH = (J1S-2)*IJD + IRD(IR1)
                      IXS = I1S + IXH
                      IXF = I1F + IXH
                      DO 290 J1 = J1S,J1F
                          IXS = IXS + IJD
                          KDS = ISTART(IXS)
                          IXF = IXF + IJD
                          KDF = ISTART(IXF+1) - 1
                          IF (KDF.LT.KDS) GO TO 290
                          DO 280 KD = KDS,KDF
                              KCV = KCV + 1
                              KH(KCV) = IFINAL(KD)
  280                     CONTINUE
  290                 CONTINUE
  300             CONTINUE
                  DO 310 ICV = 1,10
                      IF (KCV.LE.NCV(ICV)) GO TO 310
                      NCV(ICV) = KCV
                      GO TO 320
  310             CONTINUE
c
c
  320             DO 470 LDO = LS,LF
                      L = IFINAL(LDO)
                      ITH = ITYPE(L)
                      IF (ITH.EQ.0) GO TO 470
                      LTP(1) = 0
                      LTP(2) = 0
                      LTP(3) = 0
                      ID1 = ITH/100
                      ITH = ITH - 100*ID1
                      ID2 = ITH/10
                      ID3 = ITH - 10*ID2
                      IF (ID1.NE.0) LTP(ID1) = 1
                      IF (ID2.NE.0) LTP(ID2) = 1
                      IF (ID3.NE.0) LTP(ID3) = 1
c     if((ith.eq.123) .or. (ith.eq.12) .or.(ith.eq.13)) ltp(1) = 1
c     if((ith.eq.123) .or. (ith.eq.23) .or.(ith.eq.12)) ltp(2) = 1
c     if((ith.eq.123) .or. (ith.eq.13) .or.(ith.eq.23)) ltp(3) = 1
                      DO 460 NS = 1,3
                          GO TO (101,102,103) NS
  101                     IF (LTP(NS).EQ.0) GO TO 460
                          PX4 = PX1(L)
                          PY4 = PY1(L)
                          PX5 = PX2(L)
                          PY5 = PY2(L)
                          X4 = X1(L)
                          Y4 = Y1(L)
                          Z4 = Z1(L)
                          X5 = X2(L)
                          Y5 = Y2(L)
                          Z5 = Z2(L)
                          GO TO 105
  102                     IF (LTP(NS).EQ.0) GO TO 460
                          PX4 = PX2(L)
                          PY4 = PY2(L)
                          PX5 = PX3(L)
                          PY5 = PY3(L)
                          X4 = X2(L)
                          Y4 = Y2(L)
                          Z4 = Z2(L)
                          X5 = X3(L)
                          Y5 = Y3(L)
                          Z5 = Z3(L)
                          GO TO 105
  103                     IF (LTP(NS).EQ.0) GO TO 460
                          PX4 = PX1(L)
                          PY4 = PY1(L)
                          PX5 = PX3(L)
                          PY5 = PY3(L)
                          X4 = X1(L)
                          Y4 = Y1(L)
                          Z4 = Z1(L)
                          X5 = X3(L)
                          Y5 = Y3(L)
                          Z5 = Z3(L)
  105                     X54 = PX5 - PX4
                          Y54 = PY5 - PY4
                          NSEG = 0
                          DO 440 KD = 1,KCV
                              K = KH(KD)
                              C17 = VX1(K)*Y54 - VY1(K)*X54
                              C27 = VX2(K)*Y54 - VY2(K)*X54
                              C37 = VX3(K)*Y54 - VY3(K)*X54
                              C14 = VY1(K)* (PX4-PX1(K)) -
     +                              VX1(K)* (PY4-PY1(K))
                              C25 = VY2(K)* (PX4-PX2(K)) -
     +                              VX2(K)* (PY4-PY2(K))
                              C36 = VY3(K)* (PX4-PX3(K)) -
     +                              VX3(K)* (PY4-PY3(K))
                              TMIN = 0.D0
                              TMAX = 1.D0
                              IF (C17) 151,152,153
  151                         TMAX = DMIN1(C14/C17,TMAX)
                              GO TO 154
  152                         IF (C14) 154,440,440
  153                         TMIN = DMAX1(C14/C17,TMIN)
  154                         IF (C27) 155,156,157
  155                         TMAX = DMIN1(C25/C27,TMAX)
                              GO TO 158
  156                         IF (C25) 158,440,440
  157                         TMIN = DMAX1(C25/C27,TMIN)
  158                         IF (C37) 159,160,161
  159                         TMAX = DMIN1(C36/C37,TMAX)
                              GO TO 162
  160                         IF (C36) 162,440,440
  161                         TMIN = DMAX1(C36/C37,TMIN)
  162                         IF (TMAX-TMIN.LT..00001D0) GO TO 440
                              XPL = X4 + TMIN* (X5-X4)
                              YPL = Y4 + TMIN* (Y5-Y4)
                              ZPL = Z4 + TMIN* (Z5-Z4)
                              XPR = X4 + TMAX* (X5-X4)
                              YPR = Y4 + TMAX* (Y5-Y4)
                              ZPR = Z4 + TMAX* (Z5-Z4)
c
c     the projections of line and plane intersect
c     now determine if plane covers line
c
                              VX1T = X2(K) - X1(K)
                              VY1T = Y2(K) - Y1(K)
                              VZ1T = Z2(K) - Z1(K)
                              VX2T = X3(K) - X1(K)
                              VY2T = Y3(K) - Y1(K)
                              VZ2T = Z3(K) - Z1(K)
                              APL = VY1T*VZ2T - VY2T*VZ1T
                              BPL = VX2T*VZ1T - VX1T*VZ2T
                              CPL = VX1T*VY2T - VX2T*VY1T
                              DPL = APL*X1(K) + BPL*Y1(K) + CPL*Z1(K)
                              VX3T = XPL - XEYE
                              VY3T = YPL - YEYE
                              VZ3T = ZPL - ZEYE
                              DEN = APL*VX3T + BPL*VY3T + CPL*VZ3T
                              TIL = 0.D0
                              IF (DEN.EQ.0.D0) GO TO 410
                              TIL = (DPL-APL*XEYE-BPL*YEYE-CPL*ZEYE)/DEN
  410                         VX3T = XPR - XEYE
                              VY3T = YPR - YEYE
                              VZ3T = ZPR - ZEYE
                              DEN = APL*VX3T + BPL*VY3T + CPL*VZ3T
                              TIR = 0.D0
                              IF (DEN.EQ.0.D0) GO TO 412
                              TIR = (DPL-APL*XEYE-BPL*YEYE-CPL*ZEYE)/DEN
  412                         IF (TIL.GE..99999D0 .AND.
     +                            TIR.GE..99999D0) GO TO 440
                              IF (TIL.LT.1.D0 .AND.
     +                            TIR.LT.1.D0) GO TO 164
                              VX3T = XPR - XPL
                              VY3T = YPR - YPL
                              VZ3T = ZPR - ZPL
                              DEN = APL*VX3T + BPL*VY3T + CPL*VZ3T
                              TIM = 0.D0
                              IF (DEN.EQ.0.D0) GO TO 414
                              TIM = (DPL-APL*XPL-BPL*YPL-CPL*ZPL)/DEN
  414                         THOLD = TMIN + TIM* (TMAX-TMIN)
                              IF (TIL.GE.1.D0) GO TO 163
                              TMAX = THOLD
                              GO TO 164
  163                         TMIN = THOLD
  164                         NSEG = NSEG + 1
                              TL(NSEG) = TMIN
                              TR(NSEG) = TMAX
  440                     CONTINUE
                          MAXS = MAX0(MAXS,NSEG)
                          IF (NSEG-1) 171,180,172
  171                     CALL LINE(PX4,PY4,PX5,PY5)
                          GO TO 460
c
c     order the segments according to left end point tl(k)
c
  172                     DO 173 K = 2,NSEG
                              DO 173 I = K,NSEG
                                  IF (TL(K-1).LE.TL(I)) GO TO 173
                                  TLH = TL(K-1)
                                  TRH = TR(K-1)
                                  TL(K-1) = TL(I)
                                  TR(K-1) = TR(I)
                                  TL(I) = TLH
                                  TR(I) = TRH
  173                     CONTINUE
c
c     eliminate segment overlap
c
                          K1 = 1
                          K2 = 1
  174                     K2 = K2 + 1
                          IF (K2.GT.NSEG) GO TO 176
                          IF (TR(K1).LT.TL(K2)) GO TO 175
                          TR(K1) = DMAX1(TR(K1),TR(K2))
                          GO TO 174
  175                     K1 = K1 + 1
                          TL(K1) = TL(K2)
                          TR(K1) = TR(K2)
                          GO TO 174
  176                     NSEG = K1
c
c     plot all segments of the line
c
  180                     DO 181 KS = 1,NSEG
                              KB = NSEG - KS + 1
                              TL(KB+1) = TR(KB)
                              TR(KB) = TL(KB)
  181                     CONTINUE
                          TL(1) = 0.D0
                          TR(NSEG+1) = 1.D0
                          NSEGP = NSEG + 1
                          DO 450 K = 1,NSEGP
                              IF (ABS(TR(K)-TL(K)).LT.
     +                            .000001D0) GO TO 450
                              XA = PX4 + TL(K)* (PX5-PX4)
                              YA = PY4 + TL(K)* (PY5-PY4)
                              XB = PX4 + TR(K)* (PX5-PX4)
                              YB = PY4 + TR(K)* (PY5-PY4)
                              CALL LINE(XA,YA,XB,YB)
  450                     CONTINUE
  460                 CONTINUE
  470             CONTINUE
  480         CONTINUE
  490     CONTINUE
  500 CONTINUE
c      write(6,903) tl1,tl2
  903 FORMAT (' time to cover',D15.6,/,' time to test ',D15.6)
c      write(6,904) maxs
  904 FORMAT (' maximum number of segments',i5)
c      write(6,250) (ncv(icv),icv=1,10)
  250 FORMAT ('  the ten largest coverings',/, (10i5))
      CALL FRAME
      END
      SUBROUTINE DPRJCT(INIT,XEYE,YEYE,ZEYE,X,Y,Z,PX,PY)
      DOUBLE PRECISION XEYE
      DOUBLE PRECISION YEYE
      DOUBLE PRECISION ZEYE
      DOUBLE PRECISION X
      DOUBLE PRECISION Y
      DOUBLE PRECISION Z
      DOUBLE PRECISION PX
      DOUBLE PRECISION PY
      DOUBLE PRECISION RADS1
      DOUBLE PRECISION RADS2
      DOUBLE PRECISION D1
      DOUBLE PRECISION D2
      DOUBLE PRECISION CX1
      DOUBLE PRECISION CY1
      DOUBLE PRECISION CX2
      DOUBLE PRECISION CY2
      DOUBLE PRECISION CZ2
      DOUBLE PRECISION CX3
      DOUBLE PRECISION CY3
      DOUBLE PRECISION CZ3
      DOUBLE PRECISION X1
      DOUBLE PRECISION Y1
      DOUBLE PRECISION Z1
      DOUBLE PRECISION RATIO
c
c     subroutine prjct projects the point x,y,z onto a plane through
c     the origin that is perpendicular to a line between the origin
c     and the eye. the projection is along the line between the eye
c     and the point x,y,z. px and py are the coordinates of the
c     projection in the plane.
c     (version 2 , 12-10-82)
c
      SAVE

      IF (INIT.NE.0) GO TO 1
      RADS1 = XEYE**2 + YEYE**2
      RADS2 = RADS1 + ZEYE**2
      D1 = SQRT(RADS1)
      D2 = SQRT(RADS2)
      IF (D1.NE.0.D0) GO TO 2
      CX1 = 1.D0
      CY1 = 0.D0
      CX2 = 0.D0
      CY2 = 1.D0
      CZ2 = 0.D0
      CX3 = 0.D0
      CY3 = 0.D0
      CZ3 = 1.D0
      RETURN
    2 CX1 = -YEYE/D1
      CY1 = XEYE/D1
      CX2 = -XEYE*ZEYE/ (D1*D2)
      CY2 = -YEYE*ZEYE/ (D1*D2)
      CZ2 = D1/D2
      CX3 = XEYE/D2
      CY3 = YEYE/D2
      CZ3 = ZEYE/D2
      RETURN
    1 X1 = CX1*X + CY1*Y
      Y1 = CX2*X + CY2*Y + CZ2*Z
      Z1 = CX3*X + CY3*Y + CZ3*Z
      RATIO = D2/ (D2-Z1)
      PX = RATIO*X1
      PY = RATIO*Y1
      RETURN
      END
      SUBROUTINE DBOX(ISD,ISTART,NEXT,L,LIST)
      DIMENSION ISTART(ISD,ISD),NEXT(1),LIST(1)

      DO 30 JD = 1,ISD
          DO 10 ID = 1,ISD
              IDX = ISTART(ID,JD)
              ISTART(ID,JD) = L + 1
              IF (IDX.EQ.0) GO TO 10
   20         L = L + 1
              LIST(L) = IDX
              IF (NEXT(IDX).EQ.0) GO TO 10
              IDX = NEXT(IDX)
              GO TO 20
   10     CONTINUE
   30 CONTINUE
      RETURN
      END


subroutine SHGLQ(lmax, zero, w, plx, norm, csphase, cnorm, exitstatus)
!------------------------------------------------------------------------------
!
!   This routine will precompute the zeros and weights that are
!   necessary for the Gauss-Legendre quadrature sherical harmonic
!   expansion routines. This routine can also calculate a matrix of
!   legendre functions on the grid nodes to speed up computations
!   in the case where more than one expansion is performed.
!   Note, if memory is an issue because of large spherical harmonic
!   degrees, DO NOT PRECOMPUTE THE ARRAY PLX!
!
!   Calling Parameters
!
!       IN
!           lmax        Maximum spherical harmonic degree to
!                       be used in all following expansions.
!
!       OUT
!           zero        An array of length (lmax + 1) which contains the Gauss
!                       points (i.e., zeros of P(l+1,m=0)).
!           w           An array of length lmax + 1 which contains the weights
!                       used in the Gauss-Legendre quadrature routines.
!
!       OPTIONAL
!           plx         Array of normalized associated Legendre Polnomials
!                       computed at the Gauss points. The size of this array
!                       must be (1:lmax+1, 1:(lmax+1)*(lmax+2)/2).
!           norm        Normalization to be used when calculating Legendre
!                       functions
!                           (1) "geodesy" (default)
!                           (2) Schmidt
!                           (3) unnormalized
!                           (4) orthonormalized
!           csphase     1: Do not include the phase factor of (-1)^m (default).
!                       -1: Apply the phase factor of (-1)^m.
!           cnorm:      1: compute complex normalized Legendre functions.
!                       0 (default): compute real normalized Legendre functions.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use SHTOOLS, only: PreGLQ, PlmBar, PlmSchmidt, PLegendreA, PlmON, PlmIndex
    use ftypes

    implicit none

    integer(int32), intent(in) :: lmax
    real(dp), intent(out) :: zero(:), w(:)
    real(dp), intent(out), optional :: plx(:,:)
    integer(int32), intent(in), optional :: norm, csphase, cnorm
    integer(int32), intent(out), optional :: exitstatus
    integer(int32) :: n, i, astat, phase, l, m, i_s, cnormin, lnorm
    real(dp) :: upper, lower, pi
    real(dp), allocatable :: pl(:)

    if (present(exitstatus)) exitstatus = 0

    if (size(zero) < lmax+1) then
        print*, "Error --- SHGLQ"
        print*, "ZERO must be dimensioned as (LMAX+1) where LMAX is ", lmax
        print*, "Input array is dimensioned ", size(zero)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(w) < lmax+1) then
        print*, "Error --- SHGLQ"
        print*, "W must be dimensioned as (LMAX+1) where LMAX is ", lmax
        print*, "Input array is dimensioned ", size(w)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    if (present(plx)) then
        if (size(plx(:,1)) < lmax +1 .or. size(plx(1,:)) &
                < (lmax+1)*(lmax+2)/2) then
            print*, "Error --- SHGLQ"
            print*, "PLX must be dimensioned as (LMAX+1, " // &
                    "(LMAX+1)*(LMAX+2)/2) where LMAX is ", lmax
            print*, "Input array is dimensioned as ", size(plx(:,1)), &
                    size(plx(1,:))
            if (present(exitstatus)) then
                exitstatus = 1
                return
            else
                stop
            end if

        end if

    end if

    if (present(norm)) then
        if (norm > 4 .or. norm < 1) then
            print*, "Error --- SHGLQ"
            print*, "Parameter NORM must be 1 (geodesy), 2 (Schmidt), " // &
                    "3 (unnormalized), or 4 (orthonormalized)."
            print*, "Input value is ", norm
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if

        end if

        lnorm = norm

    else
        lnorm = 1

    end if

    if (present(csphase)) then
        if (csphase /= -1 .and. csphase /= 1) then
            print*, "Error --- SHGLQ"
            print*, "CSPHASE must be 1 (exclude) or -1 (include)."
            print*, "Input value is ", csphase
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if

        else
            phase = csphase

        end if

    else
        phase = 1

    end if

    allocate (pl(((lmax+2)*(lmax+1))/2), stat = astat)

    if (astat /= 0) then
        print*, "Error --- SHGLQ"
        print*, "Problem allocating array PL", astat
        if (present(exitstatus)) then
            exitstatus = 3
            return
        else
            stop
        end if
    end if

    if (present(cnorm)) then
        cnormin = cnorm

    else
        cnormin = 0

    end if

    pi = acos(-1.0_dp)

    upper = 1.0_dp
    lower = -1.0_dp

    n = lmax + 1
    ! lmax is the maxium degree of the equation we
    ! are going to integrate.

    ! Determine Gauss Points and Weights.
    if (present(exitstatus)) then
        call PreGLQ(lower, upper, n, zero, w, exitstatus = exitstatus)
        if (exitstatus /= 0) return
    else
        call PreGLQ(lower, upper, n, zero, w)
    end if

    !--------------------------------------------------------------------------
    !
    !   Next, fill the array plx with all of the associated legendre polynomials
    !   evaluated at the Gauss points. The first index of this array corresponds
    !   to the Gauss point, whereas the (lmax+2)*(lmax+1)/2 elements in the
    !   second column correspond to all of the assiated legendre polynomials,
    !   ordered according to index = (l+1)*l/2 + m + 1.
    !
    !--------------------------------------------------------------------------
    if (present(plx)) then
        do i = 1, (n + 1) / 2
            if (present(exitstatus)) then
                select case(lnorm)
                    case(1)
                        call PlmBar(pl, lmax, zero(i), csphase = phase, &
                                    cnorm=cnormin, exitstatus = exitstatus)
                    case(2)
                        call PlmSchmidt(pl, lmax, zero(i), csphase = phase, &
                                        cnorm=cnormin, exitstatus = exitstatus)
                    case(3)
                        call PLegendreA(pl, lmax, zero(i), csphase = phase, &
                                        exitstatus = exitstatus)
                    case(4)
                        call PlmON(pl, lmax, zero(i), csphase = phase, &
                                   cnorm=cnormin, exitstatus = exitstatus)
                    if (exitstatus /= 0) return

                end select

            else
                select case(lnorm)
                    case(1)
                        call PlmBar(pl, lmax, zero(i), csphase = phase, &
                                    cnorm=cnormin)
                    case(2)
                        call PlmSchmidt(pl, lmax, zero(i), csphase = phase, &
                                        cnorm=cnormin)
                    case(3)
                        call PLegendreA(pl, lmax, zero(i), csphase = phase)
                    case(4)
                        call PlmON(pl, lmax, zero(i), csphase = phase, &
                                   cnorm=cnormin)

                end select

            end if

            if (i == (n + 1) / 2 .and. mod(n,2) /= 0) then
                plx(i, 1:((lmax+1)*(lmax+2))/2) = pl(1:((lmax+1)*(lmax+2))/2)

            else
                i_s = n + 1 - i
                plx(i, 1:((lmax+1)*(lmax+2))/2) = pl(1:((lmax+1)*(lmax+2))/2)

                do l = 0, lmax
                    do m = 0, l
                        plx(i_s,PlmIndex(l,m)) = plx(i,PlmIndex(l,m)) &
                                                 * (-1)**(l-m)

                    end do

                end do

            end if

        end do

        select case(lnorm)
            case(1)
                call PlmBar(pl, -1, zero(1), csphase = phase, cnorm=cnormin)
            case(2)
                call PlmSchmidt(pl, -1, zero(1), csphase = phase, cnorm=cnormin)
            case(4)
                call PlmON(pl, -1, zero(1), csphase = phase, cnorm=cnormin)

        end select

    end if

    deallocate (pl)

end subroutine SHGLQ


      SUBROUTINE DTRMEM( IOPT )
C
C     DIFFERENTIAL STIFFNESS CALCULATIONS FOR THE TRIANGULAR MEMBRANE
C     ELEMENT.  THREE 6X6 MATRICES FOR THE PIVOT POINT ARE INSERTED.
C     IF THIS ROUTINE IS CALLED FROM DTRIA OR DQUAD ONLY THE IN PLANE
C     EFFECTS ARE GENERATED AND THE STRESS VALUES ARE RETURNED.
C
C     THE VALUE OF IOPT TELLS US WHICH ROUTINE IS CALLING DTRMEM.
C      THE OPTIONS ARE
C                IOPT        ROUTINE
C               ******       *******
C                 0            DSIA
C                 1            DQDMEM
C                 2            DTRIA
C                 3            DQUAD
C
C
C     THIS ROUTINE COMPUTES AN E-MATRIX UNIQUE TO THIS ROUTINE.
C
C                       IX  IY  IZ
C                  E =  JX  JY  JZ
C                       KX  KY  KZ
C
      DOUBLE PRECISION   E             ,C
     1                  ,KD            ,SIGX
     2                  ,SIGY          ,SIGXY
     3                  ,TEMP1         ,TEMP2
     4                                 ,KIJ
     5                  ,G             ,XSUBB
     6                  ,XSUBC         ,YSUBC
     7                  ,SUM           ,MU
     8                  ,LAMDA         ,DELTA
     9                  ,TEMP          ,GAMMA1
     T                  ,GAMMA2        ,GAMMA3
     1                  ,DISP          ,T
      DOUBLE PRECISION   AREAT         ,DUMDP
C
      DIMENSION          SUM(3)        ,NECPT(6)      ,KIJ(36)
C
C
C     INTERFACE DATA BLOCKS
C
      COMMON /CONDAS/ CONSTS(5)
      COMMON /MATIN / MATID, INFLAG, ELTEMP, STRESS, SINTH, COSTH
      COMMON /MATOUT/ G11,G12,G13,G22,G23,G33,RHO,ALPHA1,ALPHA2,ALPH12,
     1       TSUB0,GSUBE,SIGTEN,SIGCOM,SIGSHE,G2X211,G2X212,G2X222
      COMMON /DS1AAA/ NPVT, ICSTM, NCSTM
      COMMON /DS1AET/ ECPT(21),ELDEF,LDTEMP,SDISP(9)
      COMMON /DS1ADP/    E(9)          ,C(54)
     1                  ,KD(36)        ,TEMP1(18)
     2                  ,TEMP2(18)
     3                  ,G(9)          ,T(9)
     4                  ,DISP(9)       ,MU
     5                  ,LAMDA         ,DELTA
     6                  ,TEMP          ,GAMMA1
     7                  ,GAMMA2        ,GAMMA3
     8                  ,AREAT         ,XSUBB
     9                  ,XSUBC         ,YSUBC
     T                  ,DUMDP(12)     ,THETA
     1                  ,ICSTM1        ,NPIVOT
     2                  ,IDUM
     3                  ,SIGX          ,SIGY           ,SIGXY
C
      EQUIVALENCE ( CONSTS(4) , DEGRA  )
      EQUIVALENCE (LDTEMP,FTEMP),(NECPT(1),ECPT(1)),(SUM(1),SIGX)
      EQUIVALENCE        (KIJ(1),KD(1))
C
C
C     ******************************************************************
C     ECPT( 1) = ELEMENT ID
C     ECPT( 2) = GRID POINT A OR 1
C     ECPT( 3) = GRID POINT B OR 2
C     ECPT( 4) = GRID POINT C OR 3
C     ECPT( 5) = THETA = ANGLE OF MATERIAL CUT IF ANISOTROPIC
C     ECPT( 6) = MATERIAL ID
C     ECPT( 7) = THICKNESS
C     ECPT( 8) = NON-STRUCTURAL MASS
C     ECPT( 9) = COORD. SYSTEM ID 1
C     ECPT(10) = X1
C     ECPT(11) = Y1
C     ECPT(12) = Z1
C     ECPT(13) = COORD. SYSTEM ID 2
C     ECPT(14) = X2
C     ECPT(15) = Y2
C     ECPT(16) = Z2
C     ECPT(17) = COORD. SYSTEM ID 3
C     ECPT(18) = X3
C     ECPT(19) = Y3
C     ECPT(20) = Z3
C     ECPT(21) = ELEMENT TEMPERATURE
C     ECPT(22) = ELEMENT DEFORMATION DELTA
C     ECPT(23) = AVG. LOADING TEMPERATURE =(-1) IF NO LOADING TEMP.
C     ECPT(24) = X-TRANS POINT 1
C     ECPT(25) = Y-TRANS POINT 1
C     ECPT(26) = Z-TRANS POINT 1
C     ECPT(27) = X-TRANS POINT 2
C     ECPT(28) = Y-TRANS POINT 2
C     ECPT(29) = Z-TRANS POINT 2
C     ECPT(30) = X-TRANS POINT 3
C     ECPT(31) = Y-TRANS POINT 3
C     ECPT(32) = Z-TRANS POINT 3
C     ******************************************************************
C//////
C     CALL BUG(4HTMET,0,ECPT,32)
C//////
C
      SIGX=0.0D0
      SIGY=0.0D0
      SIGXY=0.0D0
      IF(ECPT(7) .EQ. 0.0 .OR. NECPT(6) .EQ. 0 ) RETURN
C     FILL ELEMENT TO GLOBAL E-TRANSFORMATION MATRIX
C
C     IVEC = E(1). . .E(3)
C     JVEC = E(4). . .E(6)
C     KVEC = E(7). . .E(9)
C
      DO 10 I=1,3
   10 E(I) = DBLE( ECPT(I+13) ) - DBLE( ECPT(I+9) )
C
C     LENGTH THEN = XSUBB
C
      XSUBB = DSQRT( E(1)**2 + E(2)**2 + E(3)**2 )
C
C     R  - R   (INTERMEDIATE STEP) AND NOMALIZE IVECTOR = E(1). . .E(3)
C      C    A
C
      DO 20 I=1,3
      E(I+3) = DBLE( ECPT(I+17) ) - DBLE( ECPT(I+9) )
   20 E(I) = E(I) / XSUBB
C
C     XSUBC = I DOT (R  - R )
C                     C    A
C
      XSUBC = E(1) * E(4)  +  E(2) * E(5)  +  E(3) * E(6)
C
C     KVEC = IVEC CROSS (R  - R )
C                         C    A
C
      E(7) = E(2) * E(6)  -  E(3) * E(5)
      E(8) = E(3) * E(4)  -  E(1) * E(6)
      E(9) = E(1) * E(5)  -  E(2) * E(4)
C
C     LENGTH = YSUBC
C
      YSUBC = DSQRT(E(7)**2 + E(8)**2 + E(9)**2 )
C
C     NORMALIZE KVECTOR
      E(7) = E(7) / YSUBC
      E(8) = E(8) / YSUBC
      E(9) = E(9) / YSUBC
C
C     JVECTOR = I CROSS K
C
      E(4) = E(3) * E(8)  -  E(2) * E(9)
      E(5) = E(1) * E(9)  -  E(3) * E(7)
      E(6) = E(2) * E(7)  -  E(1) * E(8)
C
C     NORMALIZE JVECTOR TO MAKE SURE
      TEMP = DSQRT( E(4)**2 + E(5)**2 + E(6)**2 )
      E(4) = E(4) / TEMP
      E(5) = E(5) / TEMP
      E(6) = E(6) / TEMP
C
C     MU, LAMDA, AND DELTA
C
      MU    = 1.0D0 / XSUBB
      LAMDA = 1.0D0 / YSUBC
      DELTA =(XSUBC/XSUBB) - 1.0D0
      AREAT = XSUBB * YSUBC * 0.50D0 * DBLE( ECPT(7) )
C
C     C MATRIX    C  =(3X2) STORED C( 1). . .C( 6)
C                  A
C                 C  =(3X2) STORED C( 7). . .C(12)
C                  B
C                 C  =(3X2) STORED C(13). . .C(18)
C                  C
C
      C( 1) = -MU
      C( 2) =  0.0D0
      C( 3) =  0.0D0
      C( 4) =  LAMDA * DELTA
      C( 5) =  C(4)
      C( 6) = -MU
      C( 7) =  MU
      C( 8) =  0.0D0
      C( 9) =  0.0D0
      C(10) = -LAMDA * MU * XSUBC
      C(11) =  C(10)
      C(12) =  MU
      C(13) =  0.0D0
      C(14) =  0.0D0
      C(15) =  0.0D0
      C(16) =  LAMDA
      C(17) =  LAMDA
      C(18) =  0.0D0
C
      IF( IOPT .GE. 1 ) GO TO 30
C     THE REASON FOR THIS IS THAT IF THE DQDMEM ROUTINE IS CALLING,
C     EACH INDIVIDUAL SUBTRIANGLE WILL ALREADY HAVE A SINTH AND COSTH.
C
      THETA = ECPT(5) * DEGRA
      SINTH = SIN( THETA )
      COSTH = COS( THETA )
   30 IF( ABS(SINTH) .LT. 1.0E-06 ) SINTH = 0.0E0
C
      ELTEMP = ECPT(21)
      MATID = NECPT(6)
      INFLAG = 2
      CALL MAT( ECPT(1) )
C
C     FILL G-MATRIX WITH OUTPUT FROM MAT ROUTINE.
C
      G(1) = G11
      G(2) = G12
      G(3) = G13
      G(4) = G12
      G(5) = G22
      G(6) = G23
      G(7) = G13
      G(8) = G23
      G(9) = G33
C
C     G, E, C MATRICES ARE COMPLETE
C
C     FOLLOWING COMPUTES SIG , SIG , SIG      (3X1) VECTOR
C                           X     Y     XY
C
C         I=3
C      = (SUM (G)(C )(E)(T )(DISP )) - (S )(LDTEMP - T )
C         I=1      I      I      I       T            0
C
C        WHERE  S  =(G)(ALPHAS)   (3X1)
C                T
C
      SUM(1) = 0.0E0
      SUM(2) = 0.0E0
      SUM(3) = 0.0E0
C
C     MAKE DISPLACEMENT VECTOR DOUBLE PRECISION
C
      DO 40 I=1,9
   40 DISP(I) = SDISP(I)
C
      DO 90 I=1,3
C     DO WE NEED TRANSFORMATIONS
C
      IF(NECPT(4*I+5)) 50,60,50
   50 CALL TRANSD( NECPT(4*I+5),T(1))
      CALL GMMATD( T(1),3,3,0, DISP(3*I-2),3,1,0, TEMP1(1))
      GO TO 80
C
   60 DO 70 J=1,3
      IDUM=  3*(I-1)+J
   70 TEMP1(J) = DISP(IDUM)
C
   80 CALL GMMATD( E(1),2,3,0,TEMP1(1),3,1,0, TEMP2(1)  )
      CALL GMMATD( C(6*I-5),3,2,0,  TEMP2(1),2,1,0,  TEMP1(1) )
      CALL GMMATD( G(1),3,3,0,    TEMP1(1),3,1,0,    TEMP2(1) )
C
      SUM(1) = SUM(1) + TEMP2(1)
      SUM(2) = SUM(2) + TEMP2(2)
      SUM(3) = SUM(3) + TEMP2(3)
C
   90 CONTINUE
C
      IF( LDTEMP .EQ. (-1) ) GO TO 110
C     COMPUTE S MATRIX
C               T
C
      TEMP2(1) = ALPHA1
      TEMP2(2) = ALPHA2
      TEMP2(3) = ALPH12
C     ABOVE IS FOR SINGLE TO DOUBLE PRECISION.
C
      CALL GMMATD( G(1),3,3,0,  TEMP2(1),3,1,0,  TEMP1(1) )
      TEMP = FTEMP - TSUB0
      DO 100 I=1,3
  100 SUM(I) = SUM(I) - TEMP1(I) * TEMP
C
C//////
C     CALL BUG(4HSUMS,90,SUM,6)
C//////
C  90 AT 90 SIG = SUM(1),  SIG = SUM(2),  SIG   = SUM(3)
C              X              Y              XY
C
C     ABOVE SIMULATES SMA,SDR2-PHASE I+II
C     FROM ABOVE THE E MATRIX (3X3), AND THE SUM (3X1) MATRIX ALONG WITH
C     XSUBB, XSUBC, AND YSUBC ARE NOW USED...
  110 DO 120  I =1,36
  120 KD(I) =0.0D0
C
      IF( IOPT.EQ. 3 ) AREAT=AREAT/2.0D0
C
      MU = SIGX*AREAT
      LAMDA = SIGY*AREAT
      DELTA = SIGXY *AREAT
C
      IF ( IOPT .GE. 2)  GO TO 130
      KD(1) = LAMDA
      KD(2) =-DELTA
      KD(7) = KD(2)
      KD(8) = MU
  130 KD(15) = MU+LAMDA
      KD(16) =-DELTA
      KD(17) = DELTA
      KD(18) = MU -LAMDA
      KD(21) = KD(16)
      KD(27) = KD(17)
      KD(33) = KD(18)
C
C     GENERATE C MATRICES
C
      DO 140 I=1,54
  140 C(I) =0.0D0
C
C     FILL NON ZERO TERMS
C
      GAMMA1 = 1.0D0 /XSUBB
      GAMMA2 = 1.0D0 /YSUBC
      GAMMA3 = XSUBC /( XSUBB*YSUBC)
      C(3) = GAMMA3 -GAMMA2
      C(6) = GAMMA1
      C(7) =-C(3)/2.0D0
      C(8) =-GAMMA1/2.0D0
      C(10)=-GAMMA1
      C(14)= C(3)
      C(16)=-C(7)
      C(17)= C(8)
C
      C(21)=-GAMMA3
      C(24)=-GAMMA1
      C(25)= GAMMA3/2.0D0
      C(26)=-C(8)
      C(28)= GAMMA1
      C(32)=-GAMMA3
      C(34)=-C(25)
      C(35)= C(26)
C
      C(39)=GAMMA2
      C(43)=-GAMMA2/2.0D0
      C(50)= GAMMA2
      C(52)=-C(43)
C
C     REPLACE C MATRICES BY  (C)(E )(T) FOR EACH POINT
      DO 200 I =1,3
      IF( NECPT(4*I+5)) 150,160,150
C
C     GLOBAL TO BASIC MATRIX T IS GENERATED AGAIN HERE
C
  150 CALL TRANSD( NECPT(4*I+5),T(1))
      CALL GMMATD( E(1),3,3,0,  T(1),3,3,0, TEMP1(1) )
      GO TO 180
  160 DO 170 J =1,9
  170 TEMP1(J) = E(J)
C
  180 CALL GMMATD( C(18*I-17),6,3,0,  TEMP1(1),3,3,0,  TEMP2(1))
      DO 190  J=1,18
      IDUM =  18*(I-1) +J
  190 C(IDUM) = TEMP2(J)
C
  200 CONTINUE
C
      DO 210 I =1,3
      IF(NECPT(I+1) .NE. NPVT) GO TO 210
      NPIVOT= I
      GO TO 220
  210 CONTINUE
      RETURN
  220 CALL GMMATD( C(18*NPIVOT-17),6,3,1, KD(1),6,6,0, TEMP1(1))
C
C     TEMP1 NOW CONTAINS                   T
C                           ( (C )(E)(T ) ) ( KD)
C                               J      J
C     WHERE J IS THE PIVOT POINT
C
C     GENERATE THE THREE BY THREE PARTITIONS IN GLOBAL COORDINATES HERE
C
      DO 240 I=1,3
      CALL GMMATD( TEMP1,3,6,0, C(18*I-17),6,3,0,TEMP2(1)  )
C//////
C     CALL BUG(4HTRMK,260,TEMP2,18)
C//////
      DO 230 J=1,36
  230 KIJ(J) = 0.0D0
      KIJ( 1) = TEMP2(1)
      KIJ( 2) = TEMP2(2)
      KIJ( 3) = TEMP2(3)
      KIJ( 7) = TEMP2(4)
      KIJ( 8) = TEMP2(5)
      KIJ( 9) = TEMP2(6)
      KIJ(13) = TEMP2(7)
      KIJ(14) = TEMP2(8)
      KIJ(15) = TEMP2(9)
C
      CALL DS1B( KIJ(1), NECPT(I+1) )
C
  240 CONTINUE
      RETURN
      END


MODULE m_interporb

! ----------------------------------------------------------------------
! MODULE: m_interporb.f03
! ----------------------------------------------------------------------
! Purpose:
!  Module for calling the interp_orb subroutine used for orbit interpolation
!
! Subroutines contained within the module:
! - interp_orb.f03
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou
!			Cooperative Research Centre for Spatial Information, Australia
! Created:	3 November 2017
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE interp_orb (fname_sp3, PRN, interv_in, NPint, orbint)

! ----------------------------------------------------------------------
! SUBROUTINE: interp_orb.f90
! ----------------------------------------------------------------------
! Purpose:
!  GNSS sp3 orbit interpolation based on Lagrange polynomials
! ----------------------------------------------------------------------
! Input arguments:
! - fname_sp3:  	Orbit file in sp3 format which contains only position vector
! - PRN:			Satellite PRN number
! - interv_in: 		Interval of the interpolation epochs (in seconds)
! - NPint:			Number of data points to be used for interpolation (defines the order of the polynomial)
! - fname_orbint:	Output file name for writing interpolated orbit array
!
! Output arguments:
! - orbint:   		Interpolated orbit including position and velocity vetors per epoch (allocatable array)
! ----------------------------------------------------------------------
! Note 1:
!  The input orbit file (sp3) is considered to include satellite position vector only
!  as this is the IGS standard product
!  During the orbit interpolation, based on Lagrange polynomials, position
!  and velocity vectors for the selected satellite (PRN) are computed and
!  provided in the output files.
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	5 August 2016
! ----------------------------------------------------------------------
! Last modified:
! - Dr. Thomas Papanikolaou, 14 November 2017:
!	Upgraded from Fortran 90 to Fortran 2003 for considering the
!	Fortran 2003 adavantages in dynamic memory allocation
! - Dr. Thomas Papanikolaou, 4 May 2020:
! 	Modified for considering case of orbits with outliers (zero values)
! 	Initial orbit interpolation alogorithm moved to the m_interporb_nom.f03
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      USE m_sp3
      USE m_lagrange
      !USE mdl_arr
      !USE mdl_write
      USE m_orb_outlier
      USE m_interporb_nom
      USE m_interporb_filt
      USE m_writearray
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      CHARACTER (LEN=300), INTENT(IN) :: fname_sp3
      !CHARACTER (LEN=300), INTENT(IN) :: fname_orbint
      INTEGER (KIND = prec_int8), INTENT(IN) :: interv_in, NPint
	  !INTEGER (KIND = 4) :: PRN
      CHARACTER (LEN=3), INTENT(IN) :: PRN
! OUT
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(:,:), ALLOCATABLE :: orbint
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      INTEGER (KIND = prec_int8) :: Nepochs, epoch_i, sz1, sz2, interv
      INTEGER (KIND = prec_int8) :: data_rate, Nepoch_int, Norb_int, NPint_1, NPint_2, Nlimit
	  INTEGER (KIND = prec_int8) :: i, j, i1, i2, ti
	  REAL (KIND = prec_d) :: SecDay_i, MJD_i
	  REAL (KIND = prec_d) :: MJD_tint, tint, Xint, Xint_1, Yint, Yint_1, Zint, Zint_1
	  REAL (KIND = prec_d) :: X, Y, Z, Vx, Vy, Vz
      INTEGER (KIND = prec_int2) :: AllocateStatus, DeAllocateStatus
      CHARACTER (LEN=300) :: fname_write
      REAL (KIND = prec_q), DIMENSION(:,:), ALLOCATABLE :: orbsp3
      REAL (KIND = prec_q), DIMENSION(:), ALLOCATABLE :: X_interp
      REAL (KIND = prec_q), DIMENSION(:), ALLOCATABLE :: Y_interp
      REAL (KIND = prec_q), DIMENSION(:,:), ALLOCATABLE :: clock_matrix
! ----------------------------------------------------------------------
      INTEGER (KIND = prec_int8) :: Noutliers
	  REAL (KIND = prec_d) :: outlier_value
      REAL (KIND = prec_q), DIMENSION(:,:), ALLOCATABLE :: orbsp3_filt, orb_out
      CHARACTER (LEN=100) :: filename

! ----------------------------------------------------------------------
! Read IGS sp3 orbit data file (position only): orbsp3
Call sp3 (fname_sp3, PRN, orbsp3, clock_matrix)
sz1 = size(orbsp3, DIM = 1)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Test input orbit for detecting outliers (coordinates with zero values):
! ----------------------------------------------------------------------
Noutliers = 0
outlier_value = 0.0D0
CALL orb_outlier (orbsp3, outlier_value, Noutliers, orbsp3_filt, orb_out)
!print *, "Noutliers ", Noutliers

IF (Noutliers == 0) THEN
! Orbit Lagrange interpolation using the input orbit matrix
CALL interp_orb_nom (fname_sp3, PRN, interv_in, NPint, orbint)

ELSE
! Orbit Lagrange interpolation after removing outliers of the input orbit matrix
CALL interp_orb_filt (orbsp3, orbsp3_filt, interv_in, NPint, orbint)

!write (filename, FMT='(A7,A3,A4)') 'orbint_', (PRN), '.out'
!Call writearray (orbint, filename)
END IF
! ----------------------------------------------------------------------

End subroutine

END Module


  subroutine ss_Zm_setup( &
      m,         k,         nstokes,        &
      ngeomax,   maxstr,    maxintstr,      &
      maxleg,    maxlay,    maxcoeffstrunc, &
      gmu,       imuv,      imu0,           &
      plm_0,     plm_m,     plm_p,          &
      u,         phase,     Zm_ss)

!-----------------------------------------------------------
! Subroutine:
!   ss_Zm_setup
!
! Purpose:
!   Determine truncated phase function per fourier moment Zm_ss
!
!                  mtrunc
!     Z_ss = 0.5 *  SUM  { (2-d0m) * Bmplus * Zm_ss }
!                    m
!
!   required for single scattering solution
!   (elastic scattering only)

! Output:
!   Zm_ss
!-------------------------------------------------------------------

  implicit none

  integer,parameter::dp=selected_real_kind(8)!double precision

  integer,intent(in):: &
     m,             &  !Fourier moment index
     k,             &  !layer index
     maxleg,        &
     maxstr,        &
     maxintstr,     &
     maxlay,        &
     maxcoeffstrunc(maxlay), & !Nr of Legendre terms (trunc.) for each layer
     nstokes,       &
     ngeomax,       &
     imuv(ngeomax), &
     imu0(ngeomax)

  real(kind=dp),intent(in):: &
     gmu(maxstr)

  real(kind=dp),intent(in):: &
     phase(nstokes,nstokes,0:maxleg,maxlay) !phase fct. moments

! Generalized spherical functions and corresponding angles u
  real(kind=dp),&
   dimension(0:maxleg,0:maxleg,maxintstr+4*ngeomax),intent(in):: &
    plm_0, &
    plm_m, &
    plm_p
  real(kind=dp),intent(in):: &
    u(maxintstr+4*ngeomax)

  real(kind=dp):: &
    pi,           &
    Zm(4)

  integer:: &
    iv, &
    l,  &
    i_st,  &
    mtrunc

  integer:: &
    imuvp, &
    imuvm, &
    imu0p, &
    imu0m

! Phase matrix for single scattering geometryc
  real(kind=dp),intent(out):: &
    Zm_ss(nstokes,ngeomax)

!-------------------------------------------------------------------

  pi = 2.d0*asin(1.d0)

! truncate sum Legendre terms at l=mtrunc
  mtrunc = maxcoeffstrunc(k)

  do iv=1,ngeomax

     imuvp = maxintstr+0*ngeomax+iv ! +uv
     imu0m = maxintstr+1*ngeomax+iv ! -u0
     imuvm = maxintstr+2*ngeomax+iv ! -uv
     imu0p = maxintstr+3*ngeomax+iv ! +u0

     do i_st = 1,4
        Zm(i_st) = 0.d0
     enddo

     do l=m,mtrunc

        Zm(1) = Zm(1) + &
                 plm_0(m,l,imuvp) * &
                  phase(1,1,l,k) * &
                   plm_0(m,l,imu0m)

        Zm(2) = Zm(2) + &
                 plm_p(m,l,imuvp) * &
                  phase(2,1,l,k) * &
                   plm_0(m,l,imu0m)

        Zm(3) = Zm(3) + &
                 plm_m(m,l,imuvp) * &
                  phase(2,1,l,k) * &
                   plm_0(m,l,imu0m)

        Zm(4) = 0.d0

    enddo

    do i_st = 1,nstokes
       Zm_ss(i_st,iv) = Zm(i_st)
    enddo

  enddo !end loop over ngeomax

  return
  end subroutine ss_Zm_setup


!==========================================================================
elemental function gsw_pt_from_pot_enthalpy_ice (pot_enthalpy_ice)
!==========================================================================
!
!  Calculates the potential temperature of ice from the potential enthalpy
!  of ice.  The reference sea pressure of both the potential temperature
!  and the potential enthalpy is zero dbar.
!
!  pot_enthalpy_ice  =  potential enthalpy of ice                  [ J/kg ]
!
!  pt0_ice  =  potential temperature of ice (ITS-90)              [ deg C ]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_cp_ice, gsw_pot_enthalpy_from_pt_ice
use gsw_mod_toolbox, only : gsw_pt_from_pot_enthalpy_ice_poly_dh
use gsw_mod_toolbox, only : gsw_pt_from_pot_enthalpy_ice_poly
use gsw_mod_toolbox, only : gsw_pt0_cold_ice_poly

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: pot_enthalpy_ice

real (r8) :: gsw_pt_from_pot_enthalpy_ice

integer :: iteration
real (r8) :: df_dt, f, mod_pot_enthalpy_ice, pt0_cold_ice, recip_df_dt
real (r8) :: pt0_cold_ice_old, pt0_ice, pt0_ice_old, ptm_cold_ice, ptm_ice

real (r8), parameter :: h00 = -6.320202333358860e5_r8 !gsw_enthalpy_ice(-gsw_t0,0)
real (r8), parameter :: p0 = 0.0_r8

mod_pot_enthalpy_ice = max(pot_enthalpy_ice,h00)

if (mod_pot_enthalpy_ice.ge.-5.1e5_r8) then

    ! For input potential enthalpies greater than -5.1e-5, the above part of
    ! the code gives the output potential temperature of ice accurate to 1e-13
    ! degrees C.

    pt0_ice = gsw_pt_from_pot_enthalpy_ice_poly(mod_pot_enthalpy_ice)

    ! The variable "df_dt" below is the derivative of the above polynomial with
    ! respect to pot_enthalpy_ice.  This is the initial value of the derivative
    ! of the function f.
    recip_df_dt = gsw_pt_from_pot_enthalpy_ice_poly_dh(mod_pot_enthalpy_ice)

    pt0_ice_old = pt0_ice
    f = gsw_pot_enthalpy_from_pt_ice(pt0_ice_old) - mod_pot_enthalpy_ice
    pt0_ice = pt0_ice_old - f*recip_df_dt
    ptm_ice = 0.5_r8*(pt0_ice + pt0_ice_old)
    recip_df_dt = 1.0_r8/gsw_cp_ice(ptm_ice,p0)
    pt0_ice = pt0_ice_old - f*recip_df_dt

else

    ! For  pot_enthalpy_ice < -5.1e5 (or pt0_ice less than about -100 deg c)
    ! these temperatures are less than those found in nature on planet earth.

    pt0_cold_ice = gsw_pt0_cold_ice_poly(mod_pot_enthalpy_ice)

    df_dt = gsw_cp_ice(pt0_cold_ice+0.02_r8,p0)
    ! the heat capacity, cp, is
    ! evaluated at 0.02 c greater than usual in order to avoid stability
    ! issues and to ensure convergence near zero absolute temperature.

    do iteration = 1, 6
        pt0_cold_ice_old = pt0_cold_ice
        f = gsw_pot_enthalpy_from_pt_ice(pt0_cold_ice_old)-mod_pot_enthalpy_ice
        pt0_cold_ice = pt0_cold_ice_old - f/df_dt
        ptm_cold_ice = 0.5_r8*(pt0_cold_ice + pt0_cold_ice_old)
        df_dt = gsw_cp_ice(ptm_cold_ice+0.02_r8,p0)
	! note the extra 0.02 c here as well
        pt0_cold_ice = pt0_cold_ice_old - f/df_dt
    end do
    pt0_ice = pt0_cold_ice

end if

!The potential temerature has a maximum error as listed in the table below.
!
!  potential temerature error (deg C)  |  @ potential temerature (deg C)
!--------------------------------------|--------------------------------
!                0.012                 |     -273.15 to -273.12
!              4 x 10^-4               |     -232.12 to -273.0
!             2.5 x 10^-6              |          -273
!              7 x 10^-9               |          -272
!            3.7 x 10^-10              |          -270
!              6 x 10^-11              |          -268
!             2.5 x 10^11              |          -266
!             3 x 10^-12               |          -260
!             7 x 10^-13               |          -250
!            2.2 x 10^-13              |          -220
!            1.7 x 10^-13              |         >= -160
!
! Note.  The above errors in each temperature range are machine precissions
! for this calculation.

gsw_pt_from_pot_enthalpy_ice = pt0_ice

return
end function

!--------------------------------------------------------------------------


      SUBROUTINE IGCAL(INOPT,YYSO,XICO,ZMS,SA,S,IG)
C
C     'IGCAL' CALCULATES THE TOTAL MOMENT OF INERTIA OF THE SATELLITE
C     IN INERTIAL SPACE ABOUT THE CENTER OF MASS OF THE SATELLITE.
C
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 IG(3,3)
C
      COMMON/DEBUG3/ ISWTCH
C
C
      DIMENSION YYSO(3,3),XICO(3),SUSE(3,3),SUSET(3,3),SA(3,3),S(3,3),
     .          DUM(3,3),D(3),XXSO(3,3)
C
C
      DO 10 I=1,3
      DO 10 J=1,3
   10 SUSE(I,J)=SA(I,J)
C
      CALL MATRAN(SUSE,SUSET,3,3)
      IF(ISWTCH.NE.0) GO TO 40
      WRITE(6,10000) INOPT
      WRITE(6,10002) ((SUSE(I,J),J=1,3),I=1,3)
      WRITE(6,10003)
      WRITE(6,10002) ((SUSET(I,J),J=1,3),I=1,3)
   40 CALL MULTM(SUSE,XICO,D,3,1,3)
      IF(ISWTCH.EQ.0) WRITE(6,10004) (D(I),I=1,3)
      CALL MULTM(SUSE,YYSO,DUM,3,3,3)
      IF(ISWTCH.EQ.0) WRITE(6,10005) ((DUM(I,J),J=1,3),I=1,3)
      CALL MULTM(DUM,SUSET,XXSO,3,3,3)
      IF(ISWTCH.EQ.0) WRITE(6,10006) ((XXSO(I,J),J=1,3),I=1,3)
C
      DO 50 I=1,3
      DO 50 J=1,3
   50 DUM(I,J)=D(I)*D(J)
      IF(ISWTCH.EQ.0) WRITE(6,10005) ((DUM(I,J),J=1,3),I=1,3)
      DO 60 I=1,3
      DO 60 J=1,3
   60 IG(I,J)=XXSO(I,J) - ZMS*DUM(I,J)
C
      RETURN
C
C
10000 FORMAT('0',2X,'INOPT ',I2)
C
10001 FORMAT('0',2X,'SUSE')
C
10002 FORMAT('0',2X,3(G20.13,2X)/3X,3(G20.13,2X)/3X,3(G20.13,2X))
C
10003 FORMAT('0',2X,'SUSE TRANSPOSE')
C
10004 FORMAT('0',2X,'D ',3(G20.13,2X))
C
10005 FORMAT('0',2X,'DUM ',3(G20.13,2X)/3X,3(G20.13,2X)/3X,3(G20.13,2X))
C
10006 FORMAT('0',2X,'XXSO',3(G20.13,2X)/3X,3(G20.13,2X)/3X,3(G20.13,2X))
C
      END


**==fecool.spg  processed by SPAG 4.50J  at 14:50 on 30 Jun 1995
      FUNCTION FECOOL(Dene,T,Ipr)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL ABIn , ABUnd , ABUnj , BIN , BINmin , BINsyz , c2 , c3 ,
     &     CNC , Dene , fc , fct , FECOOL , FEForb , FEIii , FEIiio ,
     &     FEInf , FEPerm , PTOt , st
      REAL T
      INTEGER Ipr , NBIn , NJ
C*** End of declarations inserted by SPAG

C  COOLING DUE TO FE II AND FE III ASSUMING THAT CONCE=CONCE(MG)
C  IF IRON IS NOT EXPLICITLY CALCULATED.
C  NUSSBAUMER AND STOREY FE II OMEGA'S AND ROBB FE III

      INCLUDE 'rayspec.inc'

      COMMON /PARAMS/ NJ(12) , ABUnj(12) , ABUnd , BINmin , BINsyz ,
     &                NBIn
      COMMON /COM   / CNC(12,30) , PTOt(12,220) , ABIn(MXBINS) ,
     &                BIN(MXBINS)
      COMMON /FE    / FEInf , FEPerm , FEForb , FEIii , FEIiio

      st = SQRT(T)
      c2 = CNC(6,2)
      c3 = CNC(6,3)
      IF ( NJ(11).EQ.26 ) c2 = CNC(11,2)
      IF ( NJ(11).EQ.26 ) c3 = CNC(11,3)
      fct = 1.6E11*10.**(ABUnj(11)-12.)*8.63E-6*c2/st
      FEInf = fct*(.31*.048*EXP(-553./T)+.42*.99*EXP(-11400./T))
      FEInf = FEInf*580.*st/(Dene+580.*st)
      FEPerm = fct*3.4*4.47*EXP(-55000./T)
      FEForb = fct*0.1*2.9*EXP(-33000./T)*1.2E6*st/(Dene+1.2E6*st)
      fct = 1.6E11*10.**(ABUnj(11)-12.)*8.63E-6*c3/st
      FEIii = fct*.30*.054*EXP(-625./T)*1590.*st/(Dene+1590.*st)
      FEIiio = fct*.43*2.66*EXP(-30840./T)*521000.*st/(Dene+521000.*st)

      fc = FEInf + FEPerm + FEForb + FEIii + FEIiio
      FECOOL = fc
      IF ( Ipr.NE.0 ) PRINT 99001 , fc , FEInf , FEPerm , FEForb ,
     &                      FEIii , FEIiio
      RETURN
99001 FORMAT (
     &   ' IRON COOLING; FC,II IR, II UV, II OPT, III IR, III      OPT '
     &   ,6F9.6)
      END


*----------------------------------------------------------------------*
      pure integer function msa2idxms4op(msa,mst,occ_a,occ_c)
*----------------------------------------------------------------------*
*     convert Ms(A)-value (actually 2 times Ms) to index value of
*     operator block
*     e.g.  2, 0, -2  to 1, 2, 3 ....  in most cases
*     if (mst>0 or occ(A)-occ(C)<0) a number of ms(A) values is not
*     allowed (as the neccessary ms(C) cannot be realized) and thus
*     skipped; we account for this offset by calculating (noting that
*     ms(A)max = occ(A); ms(C)max=occ(C))
*       ms(C)needed = ms(A)max + ms(total)
*       offset = (ms(C)needed - ms(C)max)/2
*     only positive offsets need to be considered as we enumerate
*     the blocks with ms(A)
*----------------------------------------------------------------------*
      implicit none

      integer, intent(in) ::
     &     msa, mst, occ_a, occ_c

      integer ::
     &     offset

      msa2idxms4op = (occ_a - msa)/2 + 1
      offset = occ_a-occ_c+mst
      if ( offset .gt. 0 )
     &     msa2idxms4op = msa2idxms4op - offset/2

      return
      end


!-----------------------------------------------------------------------
!     Module:        diagno_rogowski
!     Authors:       S. Lazerson (lazerson@pppl.gov)
!     Date:          03/02/2012
!     Description:   This subroutine calculates the response of a b-dot
!                    probe.
!-----------------------------------------------------------------------
      SUBROUTINE diagno_rogowski
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stel_kinds, ONLY: rprec
      USE diagno_runtime, pi2_diag => pi2
      USE biotsavart
      USE safe_open_mod
!-----------------------------------------------------------------------
!     Local Variables
!          ier            Error Flag
!          iunit          File ID Number
!-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER :: ier, iunit, nseg, npts,i,j,k,ig
      REAL(rprec) :: nx, ny, nz, int_fac, xp1, yp1, zp1, xp2, yp2, zp2
      REAL(rprec) :: xvec(3),bvec(3)
      REAL(rprec), ALLOCATABLE :: flux(:)
      REAL(rprec), ALLOCATABLE :: xp(:,:), yp(:,:), rp(:,:), phip(:,:),&
                                  zp(:,:), dx(:,:), dy(:,:), dz(:,:), &
                                  xmid(:,:), ymid(:,:), zmid(:,:), &
                                  eff_area(:,:)

!-----------------------------------------------------------------------
!     External Functions
!          ier            Error Flag
!          iunit          File ID Number
!-----------------------------------------------------------------------
      INTERFACE
         REAL FUNCTION db_bode(x0,y0,z0,x1,y1,z1,cg,ldb)
         USE stel_kinds, ONLY: rprec
         INTEGER, intent(in)     :: cg
         REAL(rprec), intent(in) :: x0,y0,z0,x1,y1,z1
         LOGICAL, intent(in), optional :: ldb
         END FUNCTION db_bode

         REAL FUNCTION db_midpoint(x0,y0,z0,x1,y1,z1,cg,ldb)
         USE stel_kinds, ONLY: rprec
         INTEGER, intent(in)     :: cg
         real(rprec), intent(in) :: x0,y0,z0,x1,y1,z1
         LOGICAL, intent(in), optional :: ldb
         END FUNCTION db_midpoint

         REAL FUNCTION db_simpson(x0,y0,z0,x1,y1,z1,cg,ldb)
         USE stel_kinds, ONLY: rprec
         INTEGER, intent(in)     :: cg
         REAL(rprec), intent(in) :: x0,y0,z0,x1,y1,z1
         LOGICAL, intent(in), optional :: ldb
         END FUNCTION db_simpson
      END INTERFACE
!-----------------------------------------------------------------------
!     Begin Subroutine
!-----------------------------------------------------------------------
      if(lverb) write(6,*)' --Calculating Rogowski Coil Values'
      int_fac=1./int_step
      IF (lverb) THEN
         WRITE(6,'(5X,A,2(9X,A,9X))') 'Loop','nseg','flux'
      END IF

      ! Read in diagnostic file
      iunit = 36
      CALL safe_open(iunit,ier,TRIM(seg_rog_file),'old','formatted')
      READ(iunit,*) nseg,npts
      ALLOCATE(xp(nseg,1:npts),yp(nseg,1:npts),zp(nseg,1:npts),rp(nseg,1:npts),phip(nseg,1:npts))
      ALLOCATE(dx(nseg,1:npts),dy(nseg,1:npts),dz(nseg,1:npts))
      ALLOCATE(xmid(nseg,0:npts),ymid(nseg,0:npts),zmid(nseg,0:npts))
      ALLOCATE(flux(nseg),eff_area(nseg,npts))
      DO i = 1, nseg
         DO j = 1, npts
            READ(iunit,*) rp(i,j), zp(i,j), phip(i,j), eff_area(i,j)
         END DO
      END DO
      CLOSE(iunit)
      phip = phip
      xp = rp * cos(phip)
      yp = rp * sin(phip)

      ! Now create calculate helper arrays
      ! Note there are npts points defining the loops.  However this
      ! equates to npts-1 segments making up each loop.
      dx(:,1:npts-1) = xp(:,2:npts) - xp(:,1:npts-1)
      dy(:,1:npts-1) = yp(:,2:npts) - yp(:,1:npts-1)
      dz(:,1:npts-1) = zp(:,2:npts) - zp(:,1:npts-1)
      xmid(:,1:npts-1) = 0.5 * ( xp(:,2:npts) + xp(:,1:npts-1) )
      ymid(:,1:npts-1) = 0.5 * ( yp(:,2:npts) + yp(:,1:npts-1) )
      zmid(:,1:npts-1) = 0.5 * ( zp(:,2:npts) + zp(:,1:npts-1) )

      ! Calculate Field
      DO i = 1, nseg
         IF (lmut) THEN

         ELSE
            flux(i) = 0.0
            SELECT CASE (int_type)
            CASE('midpoint')
              DO j = 1, npts-1
                 DO k = 1, int_step
                    xp1 = xp(i,j) + (k-1)*int_fac*dx(i,j)
                    yp1 = yp(i,j) + (k-1)*int_fac*dy(i,j)
                    zp1 = zp(i,j) + (k-1)*int_fac*dz(i,j)
                    xp2 = xp(i,j) + k*int_fac*dx(i,j)
                    yp2 = yp(i,j) + k*int_fac*dy(i,j)
                    zp2 = zp(i,j) + k*int_fac*dz(i,j)
                    ier = 0
                    IF (.not. lvac) flux(i)=flux(i) + db_midpoint(xp1,yp1,zp1,xp2,yp2,zp2,ier)*eff_area(i,j)
                    IF (lcoil) THEN
                       DO ig = 1, SIZE(coil_group)
                         IF (.not.luse_extcur(ig)) CYCLE
                         flux(i)=flux(i) + db_midpoint(xp1,yp1,zp1,xp2,yp2,zp2,ig)*eff_area(i,j)
                       END DO
                    END IF
                 END DO
              END DO
            CASE('simpson')
              DO j = 1, npts-1
                 DO k = 1, int_step
                    xp1 = xp(i,j) + (k-1)*int_fac*dx(i,j)
                    yp1 = yp(i,j) + (k-1)*int_fac*dy(i,j)
                    zp1 = zp(i,j) + (k-1)*int_fac*dz(i,j)
                    xp2 = xp(i,j) + k*int_fac*dx(i,j)
                    yp2 = yp(i,j) + k*int_fac*dy(i,j)
                    zp2 = zp(i,j) + k*int_fac*dz(i,j)
                    ier = 0
                    IF (.not. lvac) flux(i)=flux(i) + db_simpson(xp1,yp1,zp1,xp2,yp2,zp2,ier)*eff_area(i,j)
                    IF (lcoil) THEN
                       DO ig = 1, SIZE(coil_group)
                         IF (.not.luse_extcur(ig)) CYCLE
                         flux(i)=flux(i) + db_simpson(xp1,yp1,zp1,xp2,yp2,zp2,ig)*eff_area(i,j)
                       END DO
                    END IF
                 END DO
              END DO
            CASE('bode')
              DO j = 1, npts-1
                 DO k = 1, int_step
                    xp1 = xp(i,j) + (k-1)*int_fac*dx(i,j)
                    yp1 = yp(i,j) + (k-1)*int_fac*dy(i,j)
                    zp1 = zp(i,j) + (k-1)*int_fac*dz(i,j)
                    xp2 = xp(i,j) + k*int_fac*dx(i,j)
                    yp2 = yp(i,j) + k*int_fac*dy(i,j)
                    zp2 = zp(i,j) + k*int_fac*dz(i,j)
                    ier = 0
                    IF (.not. lvac) flux(i)=flux(i) + db_bode(xp1,yp1,zp1,xp2,yp2,zp2,ier)*eff_area(i,j)
                    IF (lcoil) THEN
                       DO ig = 1, SIZE(coil_group)
                         IF (.not.luse_extcur(ig)) CYCLE
                         flux(i)=flux(i) + db_bode(xp1,yp1,zp1,xp2,yp2,zp2,ig)*eff_area(i,j)
                       END DO
                    END IF
                 END DO
              END DO
            CASE('adaptive')

            END SELECT
            IF (lverb) THEN
               WRITE(6,'(2X,i6,10X,I5,10X,E18.8)') i, npts, flux(i)
            END IF
         END IF
      END DO
      ier = 0

      ! Output diagnostic file
      iunit = 36
      CALL safe_open(iunit,ier,'diagno_seg.'//TRIM(id_string),'replace','formatted')
      WRITE(iunit,'(1X,I4.4)') nseg
      WRITE(iunit,'(1X,1ES22.12E3)')(flux(i),i=1,nseg)
      WRITE(iunit,'(A)')'   #   flux [Wb]'
      CLOSE(iunit)

      ! Cleanup
      DEALLOCATE(xp,yp,zp,rp,phip)
      DEALLOCATE(dx,dy,dz,xmid,ymid,zmid)
      DEALLOCATE(flux,eff_area)

      RETURN
!-----------------------------------------------------------------------
!     End Subroutine
!-----------------------------------------------------------------------
      END SUBROUTINE diagno_rogowski


      real*8 function interp8 (a1, a2, av, b1, b2, bv, c1, c2, cv,
     .     t1, t2, t3, t4, t5, t6, t7, t8)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!**********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 To calculate particle time delay using type curves.
!D1
!**********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 FEHM Version 2.10 [10086-STN-2.10-00]
!D2
!D2 Initial implementation: 13-NOV-02, Programmer: Zora Dash
!D2
!D2 $Log:   /pvcs.config/fehm90/src/interp8.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:43:24   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:09:30   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!**********************************************************************
!D3
!D3 REQUIREMENTS TRACEABILITY
!D3
!D3 2.3.5 Cell-based particle-tracking module
!D3 2.3.6 Streamline particle-tracking module
!D3
!**********************************************************************
!D4
!D4 SPECIAL COMMENTS AND REFERENCES
!D4
!D4 Requirements from SDN: 10086-RD-2.20-00
!D4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
!D4   FEHM Application Version 2.20
!D4
!**********************************************************************
! Return the interpolated time value

      implicit none

      real*8 a1, a2, av, b1, b2, bv, c1, c2, cv
      real*8 t1, t2, t3, t4, t5, t6, t7, t8
      real*8 d1, d2, d3, d4, d5, d6, d7, d8, totald

      d1 = dsqrt( (dlog10 (a1) - dlog10(av))**2 +
     .     (dlog10 (b1) - dlog10(bv))**2 +
     .     (dlog10 (c1) - dlog10(cv))**2)

      d2 = dsqrt( (dlog10 (a1) - dlog10(av))**2 +
     .     (dlog10 (b1) - dlog10(bv))**2 +
     .     (dlog10 (c2) - dlog10(cv))**2)

      d3 = dsqrt( (dlog10 (a1) - dlog10(av))**2 +
     .     (dlog10 (b2) - dlog10(bv))**2 +
     .     (dlog10 (c1) - dlog10(cv))**2)

      d4 = dsqrt( (dlog10 (a1) - dlog10(av))**2 +
     .     (dlog10 (b2) - dlog10(bv))**2 +
     .     (dlog10 (c2) - dlog10(cv))**2)

      d5 = dsqrt( (dlog10 (a2) - dlog10(av))**2 +
     .     (dlog10 (b1) - dlog10(bv))**2 +
     .     (dlog10 (c1) - dlog10(cv))**2)

      d6 = dsqrt( (dlog10 (a2) - dlog10(av))**2 +
     .     (dlog10 (b1) - dlog10(bv))**2 +
     .     (dlog10 (c2) - dlog10(cv))**2)

      d7 = dsqrt( (dlog10 (a2) - dlog10(av))**2 +
     .     (dlog10 (b2) - dlog10(bv))**2 +
     .     (dlog10 (c1) - dlog10(cv))**2)

      d8 = dsqrt( (dlog10 (a2) - dlog10(av))**2 +
     .     (dlog10 (b2) - dlog10(bv))**2 +
     .     (dlog10 (c2) - dlog10(cv))**2)

      if (d1 .eq. 0) then
         interp8 = t1
         return
      end if

      if (d2 .eq. 0) then
         interp8 = t2
         return
      end if

      if (d3 .eq. 0) then
         interp8 = t3
         return
      end if

      if (d4 .eq. 0) then
         interp8 = t4
         return
      end if

      if (d5 .eq. 0) then
         interp8 = t5
         return
      end if

      if (d6 .eq. 0) then
         interp8 = t6
         return
      end if

      if (d7 .eq. 0) then
         interp8 = t7
         return
      end if

      if (d8 .eq. 0) then
         interp8 = t8
         return
      end if

      d1 = 1./d1
      d2 = 1./d2
      d3 = 1./d3
      d4 = 1./d4
      d5 = 1./d5
      d6 = 1./d6
      d7 = 1./d7
      d8 = 1./d8

      totald = 1. /(d1 + d2 + d3 + d4 + d5 + d6 + d7 + d8)

      interp8 = totald * (d1*t1 + d2*t2 + d3*t3 + d4*t4
     .     + d5*t5 + d6*t6 + d7*t7 + d8*t8)

      return
      end


      subroutine genrii(p,i1,i2,i7,r1,r2,phit,wt5_4,*)
c----i1,i2 initial state vectors.
c----i7 label of generated vector
      implicit none
      include 'constants.f'
      include 'debug.f'
      include 'impsample.f'
      include 'x1x2.f'
      integer i1,i2,i7,j,k
      double precision p(mxpart,4),rtalbe,c(4),d(4),phi,phit,jacbit
      double precision qtDp(mxpart),qsDp(mxpart),dot,r1,r2
      double precision q(4),qs(4),qt(4),beta,alpha,qsDqs,qtDqt
      double precision a,oma,x,omx,omxmin,wt0,wt5_4
      parameter(wt0=1d0/8d0/pisq)

      phi=twopi*phit
c      omxmin=one-xmin
      omxmin=one-xx(i1)
      r1=0.5d0
c      write(6,*) 'Enter r1'
c      read(5,*) r1
      write(6,*) 'Enter r2'
      read(5,*) r2
      if (impsample) then
        omx=omxmin*r1**2
        x=one-omx
        if (r2 .lt. 0.5d0) oma=(two*r2)**2
        if (r2 .ge. 0.5d0) oma=one-(two*r2-one)**2
        a=one-oma
        jacbit=four*sqrt(omx*omxmin)/(half/sqrt(oma)+half/sqrt(a))
      else
        omx=omxmin*r1
        x=one-omx
        oma=r2
        a=one-oma
        jacbit=omxmin
      endif

      alpha=omx*a
      beta=omx-alpha
      rtalbe=sqrt(beta*alpha)

      wt5_4=wt0*dot(p,i1,i2)/x**2*omx*jacbit

c      write(6,*) 'wt5_4 in genrii',wt5_4

      if (debug) write(6,*) 'jacbit in genrii',jacbit
      if (debug) write(6,*) 'wt0 in genrii',wt0
      if (debug) write(6,*) 'omxmin in genrii',omxmin
      if (debug) write(6,*) 'omx in genrii',omx
      if (debug) write(6,*) 'x in genrii',x
      if (debug) write(6,*) 'i1 in genrii',i1
      if (debug) write(6,*) 'i2 in genrii',i2
      if (debug) write(6,*) 'omxmin in genrii',omxmin
      if (debug) write(6,*) 'wt5_4 in genrii',wt5_4
      if (debug) write(6,*)

c---rescale p(i1)
      do j=1,4
      p(i1,j)=p(i1,j)/x
      enddo

c---Sudakov wrt new vectors
c---generate transverse vectors c and d with length^2=rtalbe^2*2*p1Dp2
c-- with direction in transverse plane picked by 3
      call gtperp(rtalbe,p,i1,i2,3,c,d)

c---generate p7 and auxiliary vectors
      do j=1,4
      p(i7,j)=alpha*p(i1,j)+beta*p(i2,j)+cos(phi)*c(j)+sin(phi)*d(j)
      q(j) =p(i1,j)+p(i2,j)-p(i7,j)
      qt(j)=x*p(i1,j)+p(i2,j)
      qs(j)=q(j)+qt(j)
      enddo

      qtDqt=qt(4)**2-qt(1)**2-qt(2)**2-qt(3)**2
      qsDqs=qs(4)**2-qs(1)**2-qs(2)**2-qs(3)**2

C--generate the remaining vectors 3 through i7-1
      do k=3,i7-1
      qtDp(k)=qt(4)*p(k,4)-qt(1)*p(k,1)-qt(2)*p(k,2)-qt(3)*p(k,3)
      qsDp(k)=qs(4)*p(k,4)-qs(1)*p(k,1)-qs(2)*p(k,2)-qs(3)*p(k,3)
      do j=1,4
      p(k,j)=p(k,j)+two*(qtDp(k)*q(j)/qtDqt-qsDp(k)*qs(j)/qsDqs)
      enddo
      enddo
c----this completes the generation of the new momenta;
c----we can now return

      return
      end


subroutine precip_proc

use vars
use microphysics
use micro_params
use params

implicit none

integer i,j,k
real autor, autos, accrr, accris, accrcs, accrig, accrcg
real dq, omn, omp, omg, qsatt
real pows1, pows2, powg1, powg2, powr1, powr2, tmp
real qii, qcc, qrr, qss, qgg
real df(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm)
real f0(nzm),df0(nzm)

powr1 = (3 + b_rain) / 4.
powr2 = (5 + b_rain) / 8.
pows1 = (3 + b_snow) / 4.
pows2 = (5 + b_snow) / 8.
powg1 = (3 + b_grau) / 4.
powg2 = (5 + b_grau) / 8.

if(dostatis) then

  do k=1,nzm
    do j=dimy1_s,dimy2_s
     do i=dimx1_s,dimx2_s
      df(i,j,k) = q(i,j,k)
     end do
    end do
  end do

endif

do k=1,nzm
 qpsrc(k)=0.
 qpevp(k)=0.
 do j=1,ny
  do i=1,nx

!-------     Autoconversion/accretion

   if(qn(i,j,k)+qp(i,j,k).gt.0.) then

         omn = max(0.,min(1.,(tabs(i,j,k)-tbgmin)*a_bg))
         omp = max(0.,min(1.,(tabs(i,j,k)-tprmin)*a_pr))
         omg = max(0.,min(1.,(tabs(i,j,k)-tgrmin)*a_gr))

	 if(qn(i,j,k).gt.0.) then

           qcc = qn(i,j,k) * omn
           qii = qn(i,j,k) * (1.-omn)

           if(qcc .gt. qcw0) then
            autor = alphaelq
           else
            autor = 0.
           endif

           if(qii .gt. qci0) then
            autos = betaelq*coefice(k)
           else
            autos = 0.
           endif

           accrr = 0.
           if(omp.gt.0.001) then
             qrr = qp(i,j,k) * omp
             accrr = accrrc(k) * qrr ** powr1
           end if
           accrcs = 0.
           accris = 0.
           if(omp.lt.0.999.and.omg.lt.0.999) then
             qss = qp(i,j,k) * (1.-omp)*(1.-omg)
             tmp = qss ** pows1
             accrcs = accrsc(k) * tmp
             accris = accrsi(k) * tmp
           end if
           accrcg = 0.
           accrig = 0.
           if(omp.lt.0.999.and.omg.gt.0.001) then
             qgg = qp(i,j,k) * (1.-omp)*omg
             tmp = qgg ** powg1
             accrcg = accrgc(k) * tmp
             accrig = accrgi(k) * tmp
           endif
           qcc = (qcc+dtn*autor*qcw0)/(1.+dtn*(accrr+accrcs+accrcg+autor))
           qii = (qii+dtn*autos*qci0)/(1.+dtn*(accris+accrig+autos))
           dq = dtn *(accrr*qcc + autor*(qcc-qcw0)+ &
             (accris+accrig)*qii + (accrcs+accrcg)*qcc + autos*(qii-qci0))
           dq = min(dq,qn(i,j,k))
           qp(i,j,k) = qp(i,j,k) + dq
           q(i,j,k) = q(i,j,k) - dq
           qn(i,j,k) = qn(i,j,k) - dq
	   qpsrc(k) = qpsrc(k) + dq

         elseif(qp(i,j,k).gt.qp_threshold.and.qn(i,j,k).eq.0.) then

           qsatt = 0.
           if(omn.gt.0.001) qsatt = qsatt + omn*qsatw(tabs(i,j,k),pres(k))
           if(omn.lt.0.999) qsatt = qsatt + (1.-omn)*qsati(tabs(i,j,k),pres(k))
           dq = 0.
           if(omp.gt.0.001) then
             qrr = qp(i,j,k) * omp
             dq = dq + evapr1(k)*sqrt(qrr) + evapr2(k)*qrr**powr2
           end if
           if(omp.lt.0.999.and.omg.lt.0.999) then
             qss = qp(i,j,k) * (1.-omp)*(1.-omg)
             dq = dq + evaps1(k)*sqrt(qss) + evaps2(k)*qss**pows2
           end if
           if(omp.lt.0.999.and.omg.gt.0.001) then
             qgg = qp(i,j,k) * (1.-omp)*omg
             dq = dq + evapg1(k)*sqrt(qgg) + evapg2(k)*qgg**powg2
           end if
           dq = dq * dtn * (q(i,j,k) /qsatt-1.)
           dq = max(-0.5*qp(i,j,k),dq)
           qp(i,j,k) = qp(i,j,k) + dq
           q(i,j,k) = q(i,j,k) - dq
	   qpevp(k) = qpevp(k) + dq

	 else

           q(i,j,k) = q(i,j,k) + qp(i,j,k)
	   qpevp(k) = qpevp(k) - qp(i,j,k)
           qp(i,j,k) = 0.

         endif

    endif

    dq = qp(i,j,k)
    qp(i,j,k)=max(0.,qp(i,j,k))
    q(i,j,k) = q(i,j,k) + (dq-qp(i,j,k))

  end do
 enddo
enddo

if(dostatis) then

  call stat_varscalar(q,df,f0,df0,q2leprec)
  call setvalue(qwleprec,nzm,0.)
  call stat_sw2(q,df,qwleprec)

endif

end subroutine precip_proc


C++***************************************************************
C Program to compute FFT_1D
C Calling FFT1 (either in "fft_nag.for" or "fft_jlp.for")
C WARNING: NAG FFT divides the result by SQRT(NX)
C
C JLP
C Version of 21-01-00
C Unknown problem at the end...
C--***************************************************************
	PROGRAM FFT1
        INTEGER*4 PNTR_RE, PNTR_IM, PNTR_TR, PNTR_TI, MADRID(1)
     	INTEGER*4 KOD,POWER_PHASE, ISIZE
	CHARACTER NAME*40,COMMENTS*80,ANS*1
        COMMON /VMR/MADRID

	CALL JLP_BEGIN

C Inquire the format (input/output) :
	CALL JLP_INQUIFMT

C Option:
        WRITE(6,*) ' Version Jan. 2000: unknown problem at the end!'
19	WRITE(6,15)
15	FORMAT(/,'FFT1, program to compute FFT along the columns',/,
     1  ' Options: ',/,
     1	' 1=direct FFT (in/out: real,imaginary)',/,
     1	' 2=direct FFT (in: real,ima /out: power,phase)',/,
     1	' -1=inverse FFT (in/out: real,imaginary)',/,
     1	' -2=inverse FFT (in: power,phase /out: real,ima)',/,
     1	' Enter your choice:')
	READ(5,*) KOD
	IF((IABS(KOD).NE.1).AND.(IABS(KOD).NE.2))THEN
	   WRITE(6,17)
17	   FORMAT(' Error: enter again the option')
	   GOTO 19
	ENDIF

C Input :
	WRITE(6,*)' Input image (real part):'
	READ(5,10) NAME
	CALL JLP_VM_READIMAG(PNTR_RE,NX,NY,NAME,COMMENTS)
        ISIZE=NX*NY*8
        CALL JLP_GETVM(PNTR_TR,ISIZE)
        CALL TO_DOUBLE(MADRID(PNTR_RE),MADRID(PNTR_TR),NX,NY,NX)
        IF(KOD.EQ.-1)THEN
	  CALL RECENT_FFT_1D_Y(MADRID(PNTR_TR),MADRID(PNTR_TR),NX,NY,NX)
        ENDIF

C Imaginary part:
	  IF(KOD.NE.-2) THEN
	    WRITE(6,22)
22	  FORMAT(' Input image (imaginary part):',/,
     1	' Null imaginary part? (N) ?')
	  ELSE
	    WRITE(6,23)
23	  FORMAT(' Input image (phase):',/,
     1	' Null phase? (N) ?')
	  ENDIF
C
	  READ(5,10) ANS
10	  FORMAT(A)

        ISIZE=NX*NY*8
        CALL JLP_GETVM(PNTR_TI,ISIZE)
	IF(ANS.NE.'Y'.AND.ANS.NE.'y')THEN
	  READ(5,10) NAME
	  CALL JLP_VM_READIMAG(PNTR_IM,NX1,NY1,NAME,COMMENTS)
          CALL TO_DOUBLE(MADRID(PNTR_IM),MADRID(PNTR_TI),NX,NY,NX)
          IF(KOD.EQ.-1)THEN
	    CALL RECENT_FFT_1D_Y(MADRID(PNTR_TI),MADRID(PNTR_TI),NX1,NY1,NX1)
          ENDIF
C Check the size:
	  IF((NX1.NE.NX).OR.(NY1.NE.NY))THEN
	    WRITE(6,21)
21	   FORMAT(' FATAL ERROR: Wrong size for the input images',/,
     1	' (should be the same for the real/imaginary parts)')
	    GOTO 999
	  ENDIF
	ELSE
          CALL ZERO2(MADRID(PNTR_TI),NX,NY)
	ENDIF

        IF(KOD.EQ.2)THEN
          KOD=1
          POWER_PHASE=1
        ELSE
          POWER_PHASE=0
        ENDIF
C FFT:
	WRITE(6,*) ' Start FFT along the columns'
	CALL FFT_1D_Y(MADRID(PNTR_TR),MADRID(PNTR_TI),NX,NY,NX,KOD)
	WRITE(6,*) ' FFT OK'

C Conversion to power/phase:
        IF(POWER_PHASE.EQ.1)THEN
         CALL CONVERT_TO_POWER(MADRID(PNTR_TR),MADRID(PNTR_TI),NX,NY,NX)
        ENDIF
C Output :
	WRITE(6,*)' Real part / Power spect.:'
	READ(5,10) NAME
	CALL RECENT_FFT_1D_Y(MADRID(PNTR_TR),MADRID(PNTR_TR),NX,NY,NX)
        CALL TO_REAL(MADRID(PNTR_TR),MADRID(PNTR_RE),NX,NY,NX)
        CALL JLP_FREEVM(PNTR_TR)
	CALL JLP_WRITEIMAG(MADRID(PNTR_RE),NX,NY,NX,NAME,COMMENTS)

	WRITE(6,*)' Imaginary part / Phase:'
	READ(5,10) NAME
	CALL RECENT_FFT_1D_Y(MADRID(PNTR_TI),MADRID(PNTR_TI),NX,NY,NX)
        CALL TO_REAL(MADRID(PNTR_TI),MADRID(PNTR_IM),NX,NY,NX)
        CALL JLP_FREEVM(PNTR_TI)
	CALL JLP_WRITEIMAG(MADRID(PNTR_IM),NX,NY,NX,NAME,COMMENTS)

999	CALL JLP_END
	STOP
	END
C****************************************************************
        SUBROUTINE ZERO2(ARRAY,NX,NY)
        DOUBLE PRECISION ARRAY(NX,NY)
	  DO J=1,NY
	   DO I=1,NX
	    ARRAY(I,J)=0.D0
	   ENDDO
	  ENDDO
        RETURN
        END
C****************************************************************
        SUBROUTINE ZERO1(ARRAY,NX)
        DOUBLE PRECISION ARRAY(NX)
	   DO I=1,NX
	    ARRAY(I)=0.D0
	   ENDDO
        RETURN
        END
C****************************************************************
C Copy column IX from (2D) ARRAY2 to (1D) ARRAY1
C****************************************************************
        SUBROUTINE COPY21(ARRAY2,ARRAY1,NX,NY,IX)
        DOUBLE PRECISION ARRAY2(NX,NY),ARRAY1(NY)
	  DO J=1,NY
	    ARRAY1(J)=ARRAY2(IX,J)
	  ENDDO
        RETURN
        END
C****************************************************************
C Copy (1D) ARRAY1 to column IX of (2D) ARRAY2
C****************************************************************
        SUBROUTINE COPY12(ARRAY2,ARRAY1,NX,NY,IX)
        DOUBLE PRECISION ARRAY2(NX,NY),ARRAY1(NY)
	  DO J=1,NY
	    ARRAY2(IX,J)=ARRAY1(IX)
	  ENDDO
        RETURN
        END
C****************************************************************
C Copy (REAL) ARRAY1 to (DOUBLE) ARRAY2
C****************************************************************
        SUBROUTINE TO_DOUBLE(ARRAY1,ARRAY2,NX,NY,IDIM)
        INTEGER*4 IDIM,NX,NY,I,J
        REAL ARRAY1(IDIM,*)
        DOUBLE PRECISION ARRAY2(IDIM,*)
	  DO J=1,NY
	  DO I=1,NX
	    ARRAY2(I,J)=ARRAY1(I,J)
	  ENDDO
	  ENDDO
        RETURN
        END
C****************************************************************
C Copy (DOUBLE) ARRAY1 to (REAL) ARRAY2
C****************************************************************
        SUBROUTINE TO_REAL(ARRAY1,ARRAY2,NX,NY,IDIM)
        INTEGER*4 IDIM,NX,NY,I,J
        DOUBLE PRECISION ARRAY1(IDIM,*)
        REAL ARRAY2(IDIM,*)
          WRITE(6,*) 'NX=',NX,'NY=',NY,'IDIM=',IDIM
	  DO J=1,NY
           WRITE(6,*) 'J=',J
	  DO I=1,NX
	    ARRAY2(I,J)=ARRAY1(I,J)
	  ENDDO
	  ENDDO
        RETURN
        END
C****************************************************************
C Power and phase spectrum:
        SUBROUTINE CONVERT_TO_POWER(TR,TI,NX,NY,IDIM)
        INTEGER I,J,NX,NY,IDIM
        DOUBLE PRECISION TR(IDIM,*),TI(IDIM,*)
        DOUBLE PRECISION AR,AI,PI
        PI=3.14159
C
         DO 60 J=1,NY
          DO 60 I=1,NX
            AR=TR(I,J)
            AI=TI(I,J)
            TR(I,J)=SQRT(AR*AR+AI*AI)
            IF(AR.NE.0.) THEN
               TI(I,J)=ATAN(AI/AR)
               IF(ACOS(AI/AR).LT.0.)TI(I,J)=TI(I,J)+PI
            ELSE
               IF(AI.GE.0.)THEN
                 TI(I,J)=PI/2.
               ELSE
                 TI(I,J)=3.*PI/2.
               ENDIF
            ENDIF
            IF(TI(I,J).LT.0.)TI(I,J)=TI(I,J)+2.*PI
60        CONTINUE
        RETURN
        END
C****************************************************************
C	include 'hrsa:fft_nag.for'
C	include 'hrsa:fft_jlp.for'