C FISHPK10 FROM PORTLIB                                  12/30/83
      SUBROUTINE HSTSSP (A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,
     1                   ELMBDA,F,IDIMF,PERTRB,IERROR,W)
C
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                        F I S H P A K                          *
C     *                                                               *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                  (VERSION 3.1 , OCTOBER 1980)                  *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C    * * * * * * * * *  PURPOSE    * * * * * * * * * * * * * * * * * *
C
C     HSTSSP SOLVES THE STANDARD FIVE-POINT FINITE DIFFERENCE
C     APPROXIMATION ON A STAGGERED GRID TO THE HELMHOLTZ EQUATION IN
C     SPHERICAL COORDINATES AND ON THE SURFACE OF THE UNIT SPHERE
C     (RADIUS OF 1)
C
C             (1/SIN(THETA))(D/DTHETA)(SIN(THETA)(DU/DTHETA)) +
C
C       (1/SIN(THETA)**2)(D/DPHI)(DU/DPHI) + LAMBDA*U = F(THETA,PHI)
C
C     WHERE THETA IS COLATITUDE AND PHI IS LONGITUDE.
C
C    * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C    * * * * * * * *    PARAMETER DESCRIPTION     * * * * * * * * * *
C
C            * * * * * *   ON INPUT    * * * * * *
C
C   A,B
C     THE RANGE OF THETA (COLATITUDE), I.E. A .LE. THETA .LE. B.  A
C     MUST BE LESS THAN B AND A MUST BE NON-NEGATIVE.  A AND B ARE IN
C     RADIANS.  A = 0 CORRESPONDS TO THE NORTH POLE AND B = PI
C     CORRESPONDS TO THE SOUTH POLE.
C
C
C                  * * *  IMPORTANT  * * *
C
C     IF B IS EQUAL TO PI, THEN B MUST BE COMPUTED USING THE STATEMENT
C
C     B = PIMACH(DUM)
C
C     THIS INSURES THAT B IN THE USER"S PROGRAM IS EQUAL TO PI IN THIS
C     PROGRAM WHICH PERMITS SEVERAL TESTS OF THE INPUT PARAMETERS THAT
C     OTHERWISE WOULD NOT BE POSSIBLE.
C
C                  * * * * * * * * * * * *
C
C
C
C   M
C     THE NUMBER OF GRID POINTS IN THE INTERVAL (A,B).  THE GRID POINTS
C     IN THE THETA-DIRECTION ARE GIVEN BY THETA(I) = A + (I-0.5)DTHETA
C     FOR I=1,2,...,M WHERE DTHETA =(B-A)/M.  M MUST BE GREATER THAN 2.
C
C   MBDCND
C     INDICATES THE TYPE OF BOUNDARY CONDITIONS AT THETA = A AND
C     THETA = B.
C
C     = 1  IF THE SOLUTION IS SPECIFIED AT THETA = A AND THETA = B.
C          (SEE NOTE 3 BELOW)
C
C     = 2  IF THE SOLUTION IS SPECIFIED AT THETA = A AND THE DERIVATIVE
C          OF THE SOLUTION WITH RESPECT TO THETA IS SPECIFIED AT
C          THETA = B (SEE NOTES 2 AND 3 BELOW).
C
C     = 3  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO THETA IS
C          SPECIFIED AT THETA = A (SEE NOTES 1, 2 BELOW) AND THETA = B.
C
C     = 4  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO THETA IS
C          SPECIFIED AT THETA = A (SEE NOTES 1 AND 2 BELOW) AND THE
C          SOLUTION IS SPECIFIED AT THETA = B.
C
C     = 5  IF THE SOLUTION IS UNSPECIFIED AT THETA = A = 0 AND THE
C          SOLUTION IS SPECIFIED AT THETA = B.  (SEE NOTE 3 BELOW)
C
C     = 6  IF THE SOLUTION IS UNSPECIFIED AT THETA = A = 0 AND THE
C          DERIVATIVE OF THE SOLUTION WITH RESPECT TO THETA IS
C          SPECIFIED AT THETA = B (SEE NOTE 2 BELOW).
C
C     = 7  IF THE SOLUTION IS SPECIFIED AT THETA = A AND THE
C          SOLUTION IS UNSPECIFIED AT THETA = B = PI. (SEE NOTE 3 BELOW)
C
C     = 8  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO
C          THETA IS SPECIFIED AT THETA = A (SEE NOTE 1 BELOW)
C          AND THE SOLUTION IS UNSPECIFIED AT THETA = B = PI.
C
C     = 9  IF THE SOLUTION IS UNSPECIFIED AT THETA = A = 0 AND
C          THETA = B = PI.
C
C     NOTES:  1.  IF A = 0, DO NOT USE MBDCND = 3, 4, OR 8,
C                 BUT INSTEAD USE MBDCND = 5, 6, OR 9.
C
C             2.  IF B = PI, DO NOT USE MBDCND = 2, 3, OR 6,
C                 BUT INSTEAD USE MBDCND = 7, 8, OR 9.
C
C             3.  WHEN THE SOLUTION IS SPECIFIED AT THETA = 0 AND/OR
C                 THETA = PI AND THE OTHER BOUNDARY CONDITIONS ARE
C                 COMBINATIONS OF UNSPECIFIED, NORMAL DERIVATIVE, OR
C                 PERIODICITY A SINGULAR SYSTEM RESULTS.  THE UNIQUE
C                 SOLUTION IS DETERMINED BY EXTRAPOLATION TO THE
C                 SPECIFICATION OF THE SOLUTION AT EITHER THETA = 0 OR
C                 THETA = PI.  BUT IN THESE CASES THE RIGHT SIDE OF THE
C                 SYSTEM WILL BE PERTURBED BY THE CONSTANT PERTRB.
C
C   BDA
C     A ONE-DIMENSIONAL ARRAY OF LENGTH N THAT SPECIFIES THE BOUNDARY
C     VALUES (IF ANY) OF THE SOLUTION AT THETA = A.  WHEN
C     MBDCND = 1, 2, OR 7,
C
C              BDA(J) = U(A,PHI(J)) ,              J=1,2,...,N.
C
C     WHEN MBDCND = 3, 4, OR 8,
C
C              BDA(J) = (D/DTHETA)U(A,PHI(J)) ,    J=1,2,...,N.
C
C     WHEN MBDCND HAS ANY OTHER VALUE, BDA IS A DUMMY VARIABLE.
C
C   BDB
C     A ONE-DIMENSIONAL ARRAY OF LENGTH N THAT SPECIFIES THE BOUNDARY
C     VALUES OF THE SOLUTION AT THETA = B.  WHEN MBDCND = 1,4, OR 5,
C
C              BDB(J) = U(B,PHI(J)) ,              J=1,2,...,N.
C
C     WHEN MBDCND = 2,3, OR 6,
C
C              BDB(J) = (D/DTHETA)U(B,PHI(J)) ,    J=1,2,...,N.
C
C     WHEN MBDCND HAS ANY OTHER VALUE, BDB IS A DUMMY VARIABLE.
C
C   C,D
C     THE RANGE OF PHI (LONGITUDE), I.E. C .LE. PHI .LE. D.
C     C MUST BE LESS THAN D.  IF D-C = 2*PI, PERIODIC BOUNDARY
C     CONDITIONS ARE USUALLY PRESCRIBED.
C
C   N
C     THE NUMBER OF UNKNOWNS IN THE INTERVAL (C,D).  THE UNKNOWNS IN
C     THE PHI-DIRECTION ARE GIVEN BY PHI(J) = C + (J-0.5)DPHI,
C     J=1,2,...,N, WHERE DPHI = (D-C)/N.  N MUST BE GREATER THAN 2.
C
C   NBDCND
C     INDICATES THE TYPE OF BOUNDARY CONDITIONS AT PHI = C
C     AND PHI = D.
C
C     = 0  IF THE SOLUTION IS PERIODIC IN PHI, I.E.
C          U(I,J) = U(I,N+J).
C
C     = 1  IF THE SOLUTION IS SPECIFIED AT PHI = C AND PHI = D
C          (SEE NOTE BELOW).
C
C     = 2  IF THE SOLUTION IS SPECIFIED AT PHI = C AND THE DERIVATIVE
C          OF THE SOLUTION WITH RESPECT TO PHI IS SPECIFIED AT
C          PHI = D (SEE NOTE BELOW).
C
C     = 3  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO PHI IS
C          SPECIFIED AT PHI = C AND PHI = D.
C
C     = 4  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO PHI IS
C          SPECIFIED AT PHI = C AND THE SOLUTION IS SPECIFIED AT
C          PHI = D (SEE NOTE BELOW).
C
C     NOTE:  WHEN NBDCND = 1, 2, OR 4, DO NOT USE MBDCND = 5, 6, 7, 8,
C     OR 9 (THE FORMER INDICATES THAT THE SOLUTION IS SPECIFIED AT
C     A POLE; THE LATTER INDICATES THE SOLUTION IS UNSPECIFIED).  USE
C     INSTEAD MBDCND = 1 OR 2.
C
C   BDC
C     A ONE DIMENSIONAL ARRAY OF LENGTH M THAT SPECIFIES THE BOUNDARY
C     VALUES OF THE SOLUTION AT PHI = C.   WHEN NBDCND = 1 OR 2,
C
C              BDC(I) = U(THETA(I),C) ,              I=1,2,...,M.
C
C     WHEN NBDCND = 3 OR 4,
C
C              BDC(I) = (D/DPHI)U(THETA(I),C),       I=1,2,...,M.
C
C     WHEN NBDCND = 0, BDC IS A DUMMY VARIABLE.
C
C   BDD
C     A ONE-DIMENSIONAL ARRAY OF LENGTH M THAT SPECIFIES THE BOUNDARY
C     VALUES OF THE SOLUTION AT PHI = D.  WHEN NBDCND = 1 OR 4,
C
C              BDD(I) = U(THETA(I),D) ,              I=1,2,...,M.
C
C     WHEN NBDCND = 2 OR 3,
C
C              BDD(I) = (D/DPHI)U(THETA(I),D) ,      I=1,2,...,M.
C
C     WHEN NBDCND = 0, BDD IS A DUMMY VARIABLE.
C
C   ELMBDA
C     THE CONSTANT LAMBDA IN THE HELMHOLTZ EQUATION.  IF LAMBDA IS
C     GREATER THAN 0, A SOLUTION MAY NOT EXIST.  HOWEVER, HSTSSP WILL
C     ATTEMPT TO FIND A SOLUTION.
C
C   F
C     A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE RIGHT
C     SIDE OF THE HELMHOLTZ EQUATION.  FOR I=1,2,...,M AND J=1,2,...,N
C
C              F(I,J) = F(THETA(I),PHI(J)) .
C
C     F MUST BE DIMENSIONED AT LEAST M X N.
C
C   IDIMF
C     THE ROW (OR FIRST) DIMENSION OF THE ARRAY F AS IT APPEARS IN THE
C     PROGRAM CALLING HSTSSP.  THIS PARAMETER IS USED TO SPECIFY THE
C     VARIABLE DIMENSION OF F.  IDIMF MUST BE AT LEAST M.
C
C   W
C     A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED BY THE USER FOR
C     WORK SPACE.  W MAY REQUIRE UP TO 13M + 4N + M*INT(LOG2(N))
C     LOCATIONS.  THE ACTUAL NUMBER OF LOCATIONS USED IS COMPUTED BY
C     HSTSSP AND IS RETURNED IN THE LOCATION W(1).
C
C
C            * * * * * *   ON OUTPUT   * * * * * *
C
C   F
C     CONTAINS THE SOLUTION U(I,J) OF THE FINITE DIFFERENCE
C     APPROXIMATION FOR THE GRID POINT (THETA(I),PHI(J)) FOR
C     I=1,2,...,M, J=1,2,...,N.
C
C   PERTRB
C     IF A COMBINATION OF PERIODIC, DERIVATIVE, OR UNSPECIFIED
C     BOUNDARY CONDITIONS IS SPECIFIED FOR A POISSON EQUATION
C     (LAMBDA = 0), A SOLUTION MAY NOT EXIST.  PERTRB IS A CON-
C     STANT, CALCULATED AND SUBTRACTED FROM F, WHICH ENSURES
C     THAT A SOLUTION EXISTS.  HSTSSP THEN COMPUTES THIS
C     SOLUTION, WHICH IS A LEAST SQUARES SOLUTION TO THE
C     ORIGINAL APPROXIMATION.  THIS SOLUTION PLUS ANY CONSTANT IS ALSO
C     A SOLUTION; HENCE, THE SOLUTION IS NOT UNIQUE.  THE VALUE OF
C     PERTRB SHOULD BE SMALL COMPARED TO THE RIGHT SIDE F.
C     OTHERWISE, A SOLUTION IS OBTAINED TO AN ESSENTIALLY DIFFERENT
C     PROBLEM.  THIS COMPARISON SHOULD ALWAYS BE MADE TO INSURE THAT
C     A MEANINGFUL SOLUTION HAS BEEN OBTAINED.
C
C   IERROR
C     AN ERROR FLAG THAT INDICATES INVALID INPUT PARAMETERS.
C     EXCEPT TO NUMBERS 0 AND 14, A SOLUTION IS NOT ATTEMPTED.
C
C     =  0  NO ERROR
C
C     =  1  A .LT. 0 OR B .GT. PI
C
C     =  2  A .GE. B
C
C     =  3  MBDCND .LT. 1 OR MBDCND .GT. 9
C
C     =  4  C .GE. D
C
C     =  5  N .LE. 2
C
C     =  6  NBDCND .LT. 0 OR NBDCND .GT. 4
C
C     =  7  A .GT. 0 AND MBDCND = 5, 6, OR 9
C
C     =  8  A = 0 AND MBDCND = 3, 4, OR 8
C
C     =  9  B .LT. PI AND MBDCND .GE. 7
C
C     = 10  B = PI AND MBDCND = 2,3, OR 6
C
C     = 11  MBDCND .GE. 5 AND NDBCND = 1, 2, OR 4
C
C     = 12  IDIMF .LT. M
C
C     = 13  M .LE. 2
C
C     = 14  LAMBDA .GT. 0
C
C     SINCE THIS IS THE ONLY MEANS OF INDICATING A POSSIBLY
C     INCORRECT CALL TO HSTSSP, THE USER SHOULD TEST IERROR AFTER
C     THE CALL.
C
C   W
C     W(1) CONTAINS THE REQUIRED LENGTH OF W.
C
C
C    * * * * * * *   PROGRAM SPECIFICATIONS    * * * * * * * * * * * *
C
C    DIMENSION OF   BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N),
C    ARGUMENTS      W(SEE ARGUMENT LIST)
C
C    LATEST         JUNE 1, 1977
C    REVISION
C
C    SUBPROGRAMS    HSTSSP,POISTG,POSTG2,GENBUN,POISD2,POISN2,POISP2,
C    REQUIRED       COSGEN,MERGE,TRIX,TRI3,PIMACH
C
C    SPECIAL        NONE
C    CONDITIONS
C
C    COMMON         NONE
C    BLOCKS
C
C    I/O            NONE
C
C    PRECISION      SINGLE
C
C    SPECIALIST     ROLAND SWEET
C
C    LANGUAGE       FORTRAN
C
C    HISTORY        WRITTEN BY ROLAND SWEET AT NCAR IN APRIL, 1977
C
C    ALGORITHM      THIS SUBROUTINE DEFINES THE FINITE-DIFFERENCE
C                   EQUATIONS, INCORPORATES BOUNDARY DATA, ADJUSTS THE
C                   RIGHT SIDE WHEN THE SYSTEM IS SINGULAR AND CALLS
C                   EITHER POISTG OR GENBUN WHICH SOLVES THE LINEAR
C                   SYSTEM OF EQUATIONS.
C
C    SPACE          8427(DECIMAL) = 20353(OCTAL) LOCATIONS ON THE
C    REQUIRED       NCAR CONTROL DATA 7600
C
C     TIMING AND        THE EXECUTION TIME T ON THE NCAR CONTROL DATA
C     ACCURACY       7600 FOR SUBROUTINE HSTSSP IS ROUGHLY PROPORTIONAL
C                    TO M*N*LOG2(N).  SOME TYPICAL VALUES ARE LISTED IN
C                    THE TABLE BELOW.
C                       THE SOLUTION PROCESS EMPLOYED RESULTS IN A LOSS
C                    OF NO MORE THAN FOUR SIGNIFICANT DIGITS FOR N AND M
C                    AS LARGE AS 64.  MORE DETAILED INFORMATION ABOUT
C                    ACCURACY CAN BE FOUND IN THE DOCUMENTATION FOR
C                    SUBROUTINE POISTG WHICH IS THE ROUTINE THAT
C                    ACTUALLY SOLVES THE FINITE DIFFERENCE EQUATIONS.
C
C
C                       M(=N)    MBDCND    NBDCND    T(MSECS)
C                       -----    ------    ------    --------
C
C                        32       1-9       1-4         56
C                        64       1-9       1-4        230
C
C    PORTABILITY    AMERICAN NATIONAL STANDARDS INSTITUTE FORTRAN.
C                   ALL MACHINE DEPENDENT CONSTANTS ARE LOCATED IN THE
C                   FUNCTION PIMACH.
C
C    REQUIRED       COS
C    RESIDENT
C    ROUTINES
C
C    REFERENCE      SCHUMANN, U. AND R. SWEET,"A DIRECT METHOD FOR
C                   THE SOLUTION OF POISSON"S EQUATION WITH NEUMANN
C                   BOUNDARY CONDITIONS ON A STAGGERED GRID OF
C                   ARBITRARY SIZE," J. COMP. PHYS. 20(1976),
C                   PP. 171-182.
C
C    * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
      DIMENSION       F(IDIMF,1) ,BDA(1)     ,BDB(1)     ,BDC(1)     ,
     1                BDD(1)     ,W(1)
      IERROR = 0
      PI = PIMACH(DUM)
      IF (A.LT.0. .OR. B.GT.PI) IERROR = 1
      IF (A .GE. B) IERROR = 2
      IF (MBDCND.LE.0 .OR. MBDCND.GT.9) IERROR = 3
      IF (C .GE. D) IERROR = 4
      IF (N .LE. 2) IERROR = 5
      IF (NBDCND.LT.0 .OR. NBDCND.GE.5) IERROR = 6
      IF (A.GT.0. .AND. (MBDCND.EQ.5 .OR. MBDCND.EQ.6 .OR. MBDCND.EQ.9))
     1    IERROR = 7
      IF (A.EQ.0. .AND. (MBDCND.EQ.3 .OR. MBDCND.EQ.4 .OR. MBDCND.EQ.8))
     1    IERROR = 8
      IF (B.LT.PI .AND. MBDCND.GE.7) IERROR = 9
      IF (B.EQ.PI .AND. (MBDCND.EQ.2 .OR. MBDCND.EQ.3 .OR. MBDCND.EQ.6))
     1    IERROR = 10
      IF (MBDCND.GE.5 .AND.
     1    (NBDCND.EQ.1 .OR. NBDCND.EQ.2 .OR. NBDCND.EQ.4)) IERROR = 11
      IF (IDIMF .LT. M) IERROR = 12
      IF (M .LE. 2) IERROR = 13
      IF (IERROR .NE. 0) RETURN
      DELTAR = (B-A)/FLOAT(M)
      DLRSQ = DELTAR**2
      DELTHT = (D-C)/FLOAT(N)
      DLTHSQ = DELTHT**2
      NP = NBDCND+1
      ISW = 1
      JSW = 1
      MB = MBDCND
      IF (ELMBDA .NE. 0.) GO TO 105
      GO TO (101,102,105,103,101,105,101,105,105),MBDCND
  101 IF (A.NE.0. .OR. B.NE.PI) GO TO 105
      MB = 9
      GO TO 104
  102 IF (A .NE. 0.) GO TO 105
      MB = 6
      GO TO 104
  103 IF (B .NE. PI) GO TO 105
      MB = 8
  104 JSW = 2
  105 CONTINUE
C
C     DEFINE A,B,C COEFFICIENTS IN W-ARRAY.
C
      IWB = M
      IWC = IWB+M
      IWR = IWC+M
      IWS = IWR+M
      DO 106 I=1,M
         J = IWR+I
         W(J) = SIN(A+(FLOAT(I)-0.5)*DELTAR)
         W(I) = SIN((A+FLOAT(I-1)*DELTAR))/DLRSQ
  106 CONTINUE
      MM1 = M-1
      DO 107 I=1,MM1
         K = IWC+I
         W(K) = W(I+1)
         J = IWR+I
         K = IWB+I
         W(K) = ELMBDA*W(J)-(W(I)+W(I+1))
  107 CONTINUE
      W(IWR) = SIN(B)/DLRSQ
      W(IWC) = ELMBDA*W(IWS)-(W(M)+W(IWR))
      DO 109 I=1,M
         J = IWR+I
         A1 = W(J)
         DO 108 J=1,N
            F(I,J) = A1*F(I,J)
  108    CONTINUE
  109 CONTINUE
C
C     ENTER BOUNDARY DATA FOR THETA-BOUNDARIES.
C
      GO TO (110,110,112,112,114,114,110,112,114),MB
  110 A1 = 2.*W(1)
      W(IWB+1) = W(IWB+1)-W(1)
      DO 111 J=1,N
         F(1,J) = F(1,J)-A1*BDA(J)
  111 CONTINUE
      GO TO 114
  112 A1 = DELTAR*W(1)
      W(IWB+1) = W(IWB+1)+W(1)
      DO 113 J=1,N
         F(1,J) = F(1,J)+A1*BDA(J)
  113 CONTINUE
  114 GO TO (115,117,117,115,115,117,119,119,119),MB
  115 A1 = 2.*W(IWR)
      W(IWC) = W(IWC)-W(IWR)
      DO 116 J=1,N
         F(M,J) = F(M,J)-A1*BDB(J)
  116 CONTINUE
      GO TO 119
  117 A1 = DELTAR*W(IWR)
      W(IWC) = W(IWC)+W(IWR)
      DO 118 J=1,N
         F(M,J) = F(M,J)-A1*BDB(J)
  118 CONTINUE
C
C     ENTER BOUNDARY DATA FOR PHI-BOUNDARIES.
C
  119 A1 = 2./DLTHSQ
      GO TO (129,120,120,122,122),NP
  120 DO 121 I=1,M
         J = IWR+I
         F(I,1) = F(I,1)-A1*BDC(I)/W(J)
  121 CONTINUE
      GO TO 124
  122 A1 = 1./DELTHT
      DO 123 I=1,M
         J = IWR+I
         F(I,1) = F(I,1)+A1*BDC(I)/W(J)
  123 CONTINUE
  124 A1 = 2./DLTHSQ
      GO TO (129,125,127,127,125),NP
  125 DO 126 I=1,M
         J = IWR+I
         F(I,N) = F(I,N)-A1*BDD(I)/W(J)
  126 CONTINUE
      GO TO 129
  127 A1 = 1./DELTHT
      DO 128 I=1,M
         J = IWR+I
         F(I,N) = F(I,N)-A1*BDD(I)/W(J)
  128 CONTINUE
  129 CONTINUE
C
C     ADJUST RIGHT SIDE OF SINGULAR PROBLEMS TO INSURE EXISTENCE OF A
C     SOLUTION.
C
      PERTRB = 0.
      IF (ELMBDA) 139,131,130
  130 IERROR = 14
      GO TO 139
  131 GO TO (139,139,132,139,139,132,139,132,132),MB
  132 GO TO (133,139,139,133,139),NP
  133 CONTINUE
      ISW = 2
      DO 135 J=1,N
         DO 134 I=1,M
            PERTRB = PERTRB+F(I,J)
  134    CONTINUE
  135 CONTINUE
      A1 = FLOAT(N)*(COS(A)-COS(B))/(2.*SIN(0.5*DELTAR))
      PERTRB = PERTRB/A1
      DO 137 I=1,M
         J = IWR+I
         A1 = PERTRB*W(J)
         DO 136 J=1,N
            F(I,J) = F(I,J)-A1
  136    CONTINUE
  137 CONTINUE
      A2 = 0.
      A3 = 0.
      DO 138 J=1,N
         A2 = A2+F(1,J)
         A3 = A3+F(M,J)
  138 CONTINUE
      A2 = A2/W(IWR+1)
      A3 = A3/W(IWS)
  139 CONTINUE
C
C     MULTIPLY I-TH EQUATION THROUGH BY  R(I)*DELTHT**2
C
      DO 141 I=1,M
         J = IWR+I
         A1 = DLTHSQ*W(J)
         W(I) = A1*W(I)
         J = IWC+I
         W(J) = A1*W(J)
         J = IWB+I
         W(J) = A1*W(J)
         DO 140 J=1,N
            F(I,J) = A1*F(I,J)
  140    CONTINUE
  141 CONTINUE
      LP = NBDCND
      W(1) = 0.
      W(IWR) = 0.
C
C     CALL POISTG OR GENBUN TO SOLVE THE SYSTEM OF EQUATIONS.
C
      IF (NBDCND .EQ. 0) GO TO 142
      CALL POISTG (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1))
      GO TO 143
  142 CALL GENBUN (LP,N,1,M,W,W(IWB+1),W(IWC+1),IDIMF,F,IERR1,W(IWR+1))
  143 CONTINUE
      W(1) = W(IWR+1)+3.*FLOAT(M)
      IF (ISW.NE.2 .OR. JSW.NE.2) GO TO 150
      IF (MB .NE. 8) GO TO 145
      A1 = 0.
      DO 144 J=1,N
         A1 = A1+F(M,J)
  144 CONTINUE
      A1 = (A1-DLRSQ*A3/16.)/FLOAT(N)
      IF (NBDCND .EQ. 3) A1 = A1+(BDD(M)-BDC(M))/(D-C)
      A1 = BDB(1)-A1
      GO TO 147
  145 A1 = 0.
      DO 146 J=1,N
         A1 = A1+F(1,J)
  146 CONTINUE
      A1 = (A1-DLRSQ*A2/16.)/FLOAT(N)
      IF (NBDCND .EQ. 3) A1 = A1+(BDD(1)-BDC(1))/(D-C)
      A1 = BDA(1)-A1
  147 DO 149 I=1,M
         DO 148 J=1,N
            F(I,J) = F(I,J)+A1
  148    CONTINUE
  149 CONTINUE
  150 CONTINUE
      RETURN
      END


*DECK CNBFA
      SUBROUTINE CNBFA (ABE, LDA, N, ML, MU, IPVT, INFO)
C***BEGIN PROLOGUE  CNBFA
C***PURPOSE  Factor a band matrix by elimination.
C***LIBRARY   SLATEC
C***CATEGORY  D2C2
C***TYPE      COMPLEX (SNBFA-S, DNBFA-D, CNBFA-C)
C***KEYWORDS  BANDED, LINEAR EQUATIONS, MATRIX FACTORIZATION,
C             NONSYMMETRIC
C***AUTHOR  Voorhees, E. A., (LANL)
C***DESCRIPTION
C
C    CNBFA factors a complex band matrix by elimination.
C
C     CNBFA is usually called by CNBCO, but it can be called
C     directly with a saving in time if RCOND is not needed.
C
C     On Entry
C
C        ABE     COMPLEX(LDA, NC)
C                contains the matrix in band storage.  The rows
C                of the original matrix are stored in the rows
C                of ABE and the diagonals of the original matrix
C                are stored in columns 1 through ML+MU+1 of ABE.
C                NC must be .GE. 2*ML+MU+1 .
C                See the comments below for details.
C
C        LDA     INTEGER
C                the leading dimension of the array ABE.
C                LDA must be .GE. N .
C
C        N       INTEGER
C                the order of the original matrix.
C
C        ML      INTEGER
C                number of diagonals below the main diagonal.
C                0 .LE. ML .LT. N .
C
C        MU      INTEGER
C                number of diagonals above the main diagonal.
C                0 .LE. MU .LT. N .
C                More efficient if ML .LE. MU .
C
C     On Return
C
C        ABE     an upper triangular matrix in band storage
C                and the multipliers which were used to obtain it.
C                the factorization can be written  A = L*U  where
C                L is a product of permutation and unit lower
C                triangular matrices and  U  is upper triangular.
C
C        IPVT    INTEGER(N)
C                an integer vector of pivot indices.
C
C        INFO    INTEGER
C                =0  normal value
C                =K  if  U(K,K) .EQ. 0.0 .  This is not an error
C                condition for this subroutine, but it does
C                indicate that CNBSL will divide by zero if
C                called.  Use RCOND in CNBCO for a reliable
C                indication of singularity.
C
C     Band Storage
C
C           If  A  is a band matrix, the following program segment
C           will set up the input.
C
C                   ML = (band width below the diagonal)
C                   MU = (band width above the diagonal)
C                   DO 20 I = 1, N
C                      J1 = MAX(1, I-ML)
C                      J2 = MIN(N, I+MU)
C                      DO 10 J = J1, J2
C                         K = J - I + ML + 1
C                         ABE(I,K) = A(I,J)
C                10    CONTINUE
C                20 CONTINUE
C
C           This uses columns  1  through  ML+MU+1  of ABE .
C           Furthermore,  ML  additional columns are needed in
C           ABE  starting with column  ML+MU+2  for elements
C           generated during the triangularization.  The total
C           number of columns needed in  ABE  is  2*ML+MU+1 .
C
C     Example:  If the original matrix is
C
C           11 12 13  0  0  0
C           21 22 23 24  0  0
C            0 32 33 34 35  0
C            0  0 43 44 45 46
C            0  0  0 54 55 56
C            0  0  0  0 65 66
C
C      then  N = 6, ML = 1, MU = 2, LDA .GE. 5  and ABE should contain
C
C            * 11 12 13  +     , * = not used
C           21 22 23 24  +     , + = used for pivoting
C           32 33 34 35  +
C           43 44 45 46  +
C           54 55 56  *  +
C           65 66  *  *  +
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  CAXPY, CSCAL, CSWAP, ICAMAX
C***REVISION HISTORY  (YYMMDD)
C   800730  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CNBFA
      INTEGER LDA,N,ML,MU,IPVT(*),INFO
      COMPLEX ABE(LDA,*)
C
      INTEGER ML1,MB,M,N1,LDB,I,J,K,L,LM,LM1,LM2,MP,ICAMAX
      COMPLEX T
      COMPLEX ZDUM
      REAL CABS1
      CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
C
C***FIRST EXECUTABLE STATEMENT  CNBFA
      ML1=ML+1
      MB=ML+MU
      M=ML+MU+1
      N1=N-1
      LDB=LDA-1
      INFO=0
C
C     SET FILL-IN COLUMNS TO ZERO
C
      IF(N.LE.1)GO TO 50
      IF(ML.LE.0)GO TO 7
      DO 6 J=1,ML
        DO 5 I=1,N
          ABE(I,M+J)=(0.0E0,0.0E0)
    5   CONTINUE
    6 CONTINUE
    7 CONTINUE
C
C     GAUSSIAN ELIMINATION WITH PARTIAL ELIMINATION
C
      DO 40 K=1,N1
        LM=MIN(N-K,ML)
        LM1=LM+1
        LM2=ML1-LM
C
C     SEARCH FOR PIVOT INDEX
C
        L=-ICAMAX(LM1,ABE(LM+K,LM2),LDB)+LM1+K
        IPVT(K)=L
        MP=MIN(MB,N-K)
C
C     SWAP ROWS IF NECESSARY
C
        IF(L.NE.K)CALL CSWAP(MP+1,ABE(K,ML1),LDA,ABE(L,ML1+K-L),LDA)
C
C     SKIP COLUMN REDUCTION IF PIVOT IS ZERO
C
        IF(CABS1(ABE(K,ML1)).EQ.0.0E0) GO TO 20
C
C     COMPUTE MULTIPLIERS
C
        T=-(1.0E0,0.0E0)/ABE(K,ML1)
        CALL CSCAL(LM,T,ABE(LM+K,LM2),LDB)
C
C     ROW ELIMINATION WITH COLUMN INDEXING
C
        DO 10 J=1,MP
          CALL CAXPY (LM,ABE(K,ML1+J),ABE(LM+K,LM2),LDB,ABE(LM+K,LM2+J),
     1                LDB)
   10   CONTINUE
        GO TO 30
   20   CONTINUE
        INFO=K
   30   CONTINUE
   40 CONTINUE
   50 CONTINUE
      IPVT(N)=N
      IF(CABS1(ABE(N,ML1)).EQ.0.0E0) INFO=N
      RETURN
      END


*DECK GAMI
      FUNCTION GAMI (A, X)
C***BEGIN PROLOGUE  GAMI
C***PURPOSE  Evaluate the incomplete Gamma function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7E
C***TYPE      SINGLE PRECISION (GAMI-S, DGAMI-D)
C***KEYWORDS  FNLIB, INCOMPLETE GAMMA FUNCTION, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate the incomplete gamma function defined by
C
C GAMI = integral from T = 0 to X of EXP(-T) * T**(A-1.0) .
C
C GAMI is evaluated for positive values of A and non-negative values
C of X.  A slight deterioration of 2 or 3 digits accuracy will occur
C when GAMI is very large or very small, because logarithmic variables
C are used.  GAMI, A, and X are single precision.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  ALNGAM, GAMIT, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  GAMI
C***FIRST EXECUTABLE STATEMENT  GAMI
      IF (A .LE. 0.0) CALL XERMSG ('SLATEC', 'GAMI',
     +   'A MUST BE GT ZERO', 1, 2)
      IF (X .LT. 0.0) CALL XERMSG ('SLATEC', 'GAMI',
     +   'X MUST BE GE ZERO', 2, 2)
C
      GAMI = 0.0
      IF (X.EQ.0.0) RETURN
C
C THE ONLY ERROR POSSIBLE IN THE EXPRESSION BELOW IS A FATAL OVERFLOW.
      FACTOR = EXP (ALNGAM(A) + A*LOG(X) )
C
      GAMI = FACTOR * GAMIT(A, X)
C
      RETURN
      END


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

SUBROUTINE splin2(x1a, x2a, ya, y2a, m, n, x1, x2, y)
    !
    ! Given an m by n tabulated function ya(1:m,1:n), and tabulated independent
    ! variables x1a(1:m), x2a(1:n), and tabulated 2nd-derivatives y2a(1:m,1:n) as
    ! produced by SPLIE2; and given a desired interpolating point x1, x2; this
    ! routine returns an interpolated function value y by 2-dimensional natural
    ! cubic spline interpolation.  From "Numerical Recipes" (FORTRAN, 1992 Ed.),
    ! Ch. 3.6, p. 121.  Call this routine sequentially after one call to SPLIE2.
    ! The process is of order  m x logn + m + logm + 1 ; i.e., roughly, of order
    ! m x logn.  Therefore, the optimum choice is n > m.
    IMPLICIT NONE
    ! Passed variables:
    INTEGER m, n
    REAL  x1a(m), x2a(n), ya(m, n), y2a(m, n), x1, x2, y
    ! Local variables:
    INTEGER i, j, NN
    REAL bound
    PARAMETER (NN = 100)           ! Maximum expected value of m, n
    REAL ytmp(NN), yytmp(NN), y2tmp(NN)
    ! Boundary condition threshold for natural cubic spline:
    SAVE bound
    DATA bound/1.e30/
    !
    do i = 1, m
        do j = 1, n
            ytmp(j) = ya(i, j)
            y2tmp(j) = y2a(i, j)
        enddo
        ! Perform n evaluations of the splines of the (1:n)-dimension constructed by
        ! SPLIE2, using the 1-dimensional spline evaluator SPLINT.
        call splint(x2a, ytmp, y2tmp, n, x2, yytmp(i))
    enddo
    ! Construct the 1-dimensional natural spline of the (1:m)-dimension and
    ! evaluate it.
    call spline(x1a, yytmp, m, bound, bound, y2tmp)
    call splint(x1a, yytmp, y2tmp, m, x1, y)
    !
    return
END


    module mod_vectors
    use, intrinsic :: iso_fortran_env, only : sp=>real32, wp => real64, li => int64
    implicit none ( type, external )

    real(wp), parameter :: nan64 =  transfer(-2251799813685248_li, 1._wp)
    real(wp), parameter :: pi = 4d0*atan(1d0), deg = pi/180d0
    reaL(wp), parameter :: o_(3) = [0d0,0d0,0d0]
    reaL(wp), parameter :: i_(3) = [1d0,0d0,0d0]
    reaL(wp), parameter :: j_(3) = [0d0,1d0,0d0]
    reaL(wp), parameter :: k_(3) = [0d0,0d0,1d0]
    real(wp), parameter :: eye3(3,3) = reshape([i_,j_,k_],[3,3])

    interface eye
        procedure a_identity, a_elemental, v_elemental
    end interface
    interface null
        procedure a_null
    end interface

    interface mag
        procedure v_mag
    end interface
    !interface dot
    !    procedure v_dot
    !end interface
    interface cross
        procedure v_cross_op, v_cross
    end interface
    interface operator (.x.)
        procedure v_cross_op, v_cross
    end interface
    interface diag
        procedure v_diag, D_diag
    end interface
    interface inv
        procedure mat3_inv
    end interface
    interface solve
        procedure v_solve, v_solve2
    end interface

    contains

    pure function i_null(n, index) result(non)
    integer, intent(in) :: n, index(:)
    integer, allocatable :: non(:)
    integer i, k, nk
        nk = size(index)
        k = 0
        allocate(non(n-nk))
        do i=1, n
            if ( any(index==i) ) then
            else
                k = k + 1
                non(k) = i
            end if
        end do
    end function

    pure function a_identity(n) result(A)
    integer, intent(in) :: n
    real(wp) :: A(n,n)
    integer :: i
        A = 0d0
        forall(i=1:n)
            A(i,i) = 1d0
        end forall
    end function

    pure function v_elemental(n,i) result(v)
    integer, intent(in) :: n, i
    real(wp) :: v(n)
        v = 0d0
        v(i) = 1d0
    end function

    pure function a_elemental(n,index) result(A)
    integer, intent(in) :: n, index(:)
    real(wp), allocatable :: A(:,:)
    integer :: i, nk
        nk = size(index)
        allocate(A(n, nk), source=0d0)
        do i=1, nk
            A(index(i),i) = 1d0
        end do
    end function

    pure function a_null(n, index) result(A)
    integer, intent(in) :: n, index(:)
    real(wp), allocatable:: A(:,:)
    integer, allocatable :: non(:)
    integer :: i, nk
        nk = size(index)
        non = i_null(n, index)
        allocate(A(n,n-nk), source=0d0)
        do i=1,n-nk
            A(non(i),i) = 1d0
        end do
    end function

    pure function v_cross(v_1,v_2) result(v_3)
    real(wp), intent(in) :: v_1(3), v_2(3)
    real(wp) :: v_3(3)
        v_3 = [ v_1(2)*v_2(3)-v_1(3)*v_2(2), &
                v_1(3)*v_2(1)-v_1(1)*v_2(3), &
                v_1(1)*v_2(2)-v_1(2)*v_2(1) ]
    end function

    pure function v_cross_op(v) result(vx)
    real(wp), intent(in) :: v(3)
    real(wp) :: vx(3,3)
        vx(1,:) = [0d0, -v(3), v(2)]
        vx(2,:) = [v(3), 0d0, -v(1)]
        vx(3,:) = [-v(2), v(1), 0d0]
    end function

    pure function v_mmoi(v) result(mm)
    real(wp), intent(in) :: v(3)
    real(wp) :: mm(3,3)
        mm(1,:) = [v(2)**2+v(3)**2, -v(1)*v(2), -v(1)*v(3)]
        mm(2,:) = [-v(1)*v(2), v(1)**2+v(3)**2, -v(2)*v(3)]
        mm(3,:) = [-v(1)*v(3), -v(2)*v(3), v(1)**2+v(2)**2]
    end function

    pure function v_mag(v) result(m)
    !$omp declare simd(v_mag)
    real(wp), intent(in) :: v(:)
    real(wp) :: m
        m = sqrt( sum( v**2 ))
    end function

    pure function v_dot(v, w) result(m)
    !$omp declare simd(v_dot)
    real(wp), intent(in) :: v(:), w(:)
    real(wp) :: m
        m = sum(v*w)
	end function

    pure function v_diag(v) result(D)
    !$omp declare simd(v_diag)
    real(wp), intent(in) :: v(:)
    real(wp),allocatable :: D(:,:)
    integer :: n, i
        n = size(v)
        allocate(D(n,n))
        D = 0d0
        forall(i=1:n)
            D(i,i) = v(i)
        end forall
	end function

    pure function D_diag(D) result(v)
    !$omp declare simd(D_diag)
    real(wp), intent(in) :: D(:,:)
    real(wp), allocatable :: v(:)
    integer :: n,i
        n = min(size(D,1),size(D,2))
        allocate(v(n))
        do i=1,n
            v(i) = D(i,i)
        end do
    end function

    pure function v_matmul(A, v) result(w)
    ! evaluate w = A*v
    real(wp), intent(in) :: A(:,:), v(:)
	real(wp) :: w(size(A,1))
    integer :: i
        do i=1,size(A,1)
            w(i) = sum(A(i,:)*v(:))
        end do
    end function

    pure function v_matmul2(v, A) result(w)
    ! evaluate w = v*A
    real(wp), intent(in) :: A(:,:), v(:)
	real(wp) :: w(size(A,2))
    integer :: i
        do i=1,size(A,2)
            w(i) = sum(v(:)*A(:,i))
        end do
    end function

    pure function mat3_inv(A) result(B)
    !$omp declare simd(mat3_inv)
    real(wp), intent(in) :: A(3,3)
	real(wp) :: B(3,3), d, t2, t3, t4, t7, t8, t9, t6
        t2 = A(1,1)*A(2,2)*A(3,3)
        t3 = A(1,2)*A(2,3)*A(3,1)
        t4 = A(1,3)*A(2,1)*A(3,2)
        t7 = A(1,1)*A(2,3)*A(3,2)
        t8 = A(1,2)*A(2,1)*A(3,3)
        t9 = A(1,3)*A(2,2)*A(3,1)
        d = t2+t3+t4-t7-t8-t9
        t6 = 1.0D0/d
        B(1,1) = t6*(A(2,2)*A(3,3)-A(2,3)*A(3,2))
        B(1,2) = -t6*(A(1,2)*A(3,3)-A(1,3)*A(3,2))
        B(1,3) = t6*(A(1,2)*A(2,3)-A(1,3)*A(2,2))
        B(2,1) = -t6*(A(2,1)*A(3,3)-A(2,3)*A(3,1))
        B(2,2) = t6*(A(1,1)*A(3,3)-A(1,3)*A(3,1))
        B(2,3) = -t6*(A(1,1)*A(2,3)-A(1,3)*A(2,1))
        B(3,1) = t6*(A(2,1)*A(3,2)-A(2,2)*A(3,1))
        B(3,2) = -t6*(A(1,1)*A(3,2)-A(1,2)*A(3,1))
        B(3,3) = t6*(A(1,1)*A(2,2)-A(1,2)*A(2,1))
    end function

    pure function v_solve(A, b) result(x)
    !$omp declare simd(v_solve)
    ! solve b = A*x for x
    real(wp), intent(in) :: A(3,3), b(3)
	real(wp) :: x(3), d, w(3)

        d = A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2))+A(1,2)*(A(2,3)*A(3,1)-A(2,1)*A(3,3))+A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1))
        w = b/d
        x = [ &
            w(1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2))+w(2)*(A(1,3)*A(3,2)-A(1,2)*A(3,3))+w(3)*(A(1,2)*A(2,3)-A(1,3)*A(2,2)), &
            w(1)*(A(2,3)*A(3,1)-A(2,1)*A(3,3))+w(2)*(A(1,1)*A(3,3)-A(1,3)*A(3,1))+w(3)*(A(1,3)*A(2,1)-A(1,1)*A(2,3)), &
            w(1)*(A(2,1)*A(3,2)-A(2,2)*A(3,1))+w(2)*(A(1,2)*A(3,1)-A(1,1)*A(3,2))+w(3)*(A(1,1)*A(2,2)-A(1,2)*A(2,1))]
    end function

    pure function v_solve2(A, B) result(x)
    !$omp declare simd(v_solve2)
    ! solve b = A*x for x
    real(wp), intent(in) :: A(3,3), B(3,3)
	real(wp) :: x(3,3), d, w(3,3)
    integer :: i

        d = A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2))+A(1,2)*(A(2,3)*A(3,1)-A(2,1)*A(3,3))+A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1))

        forall (i=1:3)
            w(:,i) = B(:,i)/d
            x(:,i) = [ &
                w(1,i)*(A(2,2)*A(3,3)-A(2,3)*A(3,2))+w(2,i)*(A(1,3)*A(3,2)-A(1,2)*A(3,3))+w(3,i)*(A(1,2)*A(2,3)-A(1,3)*A(2,2)), &
                w(1,i)*(A(2,3)*A(3,1)-A(2,1)*A(3,3))+w(2,i)*(A(1,1)*A(3,3)-A(1,3)*A(3,1))+w(3,i)*(A(1,3)*A(2,1)-A(1,1)*A(2,3)), &
                w(1,i)*(A(2,1)*A(3,2)-A(2,2)*A(3,1))+w(2,i)*(A(1,2)*A(3,1)-A(1,1)*A(3,2))+w(3,i)*(A(1,1)*A(2,2)-A(1,2)*A(2,1))]
        end forall

        !do concurrent (i=1:3)
        !    w = B(:,i)/d
        !    x(:,i) = [ &
        !        w(1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2))+w(2)*(A(1,3)*A(3,2)-A(1,2)*A(3,3))+w(3)*(A(1,2)*A(2,3)-A(1,3)*A(2,2)), &
        !        w(1)*(A(2,3)*A(3,1)-A(2,1)*A(3,3))+w(2)*(A(1,1)*A(3,3)-A(1,3)*A(3,1))+w(3)*(A(1,3)*A(2,1)-A(1,1)*A(2,3)), &
        !        w(1)*(A(2,1)*A(3,2)-A(2,2)*A(3,1))+w(2)*(A(1,2)*A(3,1)-A(1,1)*A(3,2))+w(3)*(A(1,1)*A(2,2)-A(1,2)*A(2,1))]
        !end do
    end function

    function v_rotate_x(v,q) result(u)
    real(wp), intent(in) :: v(3), q
    real(wp) :: u(3), cq, sq
        cq = cos(q)
        sq = sin(q)
        u = [ v(1), &
            cq*v(2)-sq*v(3), &
            sq*v(2)+cq*v(3)]
    end function
    function v_rotate_y(v,q) result(u)
    real(wp), intent(in) :: v(3), q
    real(wp) :: u(3), cq, sq
        cq = cos(q)
        sq = sin(q)
        u = [ cq*v(1)+sq*v(3), &
            v(2), &
            -sq*v(1)+cq*v(3)]
    end function
    function v_rotate_z(v,q) result(u)
    real(wp), intent(in) :: v(3), q
    real(wp) :: u(3), cq, sq
        cq = cos(q)
        sq = sin(q)
        u = [ cq*v(1)-sq*v(1), &
            sq*v(1)+cq*v(2), &
            v(3)]
    end function

    function a_mmul(A,x,b) result(y)
    !tex: Matrix vector calculation
    ! $$ y = A\,x + b $$
    ! or
    ! $$ y = A\,x  $$
    real(wp), intent(in) :: A(:,:), x(:)
    real(wp), intent(in), optional :: b(:)
    real(wp), allocatable :: y(:)
        if( present(b) ) then
            y = matmul(A,x)  + b
        else
            y = matmul(A,x)
        end if
    end function

    end module


subroutine PreCompute(lmax, zero, w, plx, wisdom_file, norm, csphase, cnorm)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This routine will precompute several arrays and matrixes that are
!	necessary for the Gauss-Legendre quadrature sherical harmonic
!	expansion routines. This is done only to speed up computations
!	in the case where more than one expansion is performed.
!	In addition, system-wide FFTW wisdom will be loaded, as well
!	as an optional user wisdom file. 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
!			wisdom_file	User wisdom file name.
!			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
!					-1: Apply the phase factor of (-1)^m.
!			cnorm:		1: compute complex normalized Legendre functions.
!					0 (default): compute real normalized Legendre functions.
!
!
!	Dependencies:	PreGLQ, NGLQSH, PlmBar, PlmSchmidt, PLegendreA, PlmON, CSPHASE_DEFAULT, PlmIndex
!
!	Written by Mark Wieczorek 2003
!	September 4, 2005. The array plx was turned into an optional argument. This
!	is because when the spherical harmonic degree is very large (>360), it takes
!	up a lot of memory. When doing the spherical harmonic transforms, if this array
!	is not sent to the subroutine, it will be computed for each latitude. This
!	takes place at the same speed as before. The only reason for precomputing this
!	is in case it it reused several times.
!	May 1, 2008. Added optional arguement CNORM to calculate complex normalized Legendre functions.
!
!	Copyright (c) 2005-2008, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only: PreGLQ, NGLQSH, PlmBar, PlmSchmidt, PLegendreA, PlmON, CSPHASE_DEFAULT, PlmIndex

	implicit none

	integer, intent(in) ::	lmax
	real*8, intent(out) ::	zero(:), w(:)
	real*8, intent(out), optional ::	plx(:,:)
	integer, intent(in), optional ::	norm, csphase, cnorm
	character(*), intent(in), optional ::	wisdom_file
	character ::	system_wisdom(80)
	integer ::		n, i, isuccess, fn, istat, astat, phase, l, m, i_s, cnormin
	integer, save ::	first_call = 1
	real*8  :: 		upper, lower, pi
	real*8, allocatable :: 	 pl(:)

	if (size(zero) < lmax+1) then
		print*, "Error --- PreCompute"
		print*, "ZERO must be dimensioned as (LMAX+1) where LMAX is ", lmax
		print*, "Input array is dimensioned ", size(zero)
		stop
	elseif (size(w) < lmax+1) then
		print*, "Error --- PreCompute"
		print*, "W must be dimensioned as (LMAX+1) where LMAX is ", lmax
		print*, "Input array is dimensioned ", size(w)
		stop
	endif

	if (present(plx)) then
		if (size(plx(:,1)) < lmax +1 .or. size(plx(1,:)) < (lmax+1)*(lmax+2)/2) then
			print*, "Error --- PreCompute"
			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,:))
			stop
		endif
	endif

	if (present(norm)) then
		if (norm > 4 .or. norm < 1) then
			print*, "Error - PreCompute"
			print*, "Parameter NORM must be 1 (geodesy), 2 (Schmidt), 3 (unnormalized), or 4 (orthonormalized)."
			print*, "Input value is ", norm
			stop
		endif
	endif

	if (present(csphase)) then
     		if (csphase /= -1 .and. csphase /= 1) then
     			print*, "PreCompute --- Error"
     			print*, "CSPHASE must be 1 (exclude) or -1 (include)."
     			print*, "Input value is ", csphase
     			stop
     		else
     			phase = csphase
     		endif
     	else
     		phase = CSPHASE_DEFAULT
     	endif

     	allocate(pl((lmax+2)*(lmax+1)/2), stat = astat)
     	if (astat /= 0) then
		print*, "Error --- PreCompute"
		print*, "Problem allocating array PL", astat
		stop
	endif

	if (present(cnorm)) then
		cnormin = cnorm
	else
		cnormin = 0
	endif

	pi = acos(-1.0d0)

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! 	Load FFTW wisdom files if this is the first time this routine is being called
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	if (first_call == 1) then

		system_wisdom = "/etc/fftw/wisdom"
		call dfftw_import_system_wisdom_(isuccess)

		if (isuccess /= 0) then
			print*, "Using system-wide FFTW wisdom."
		endif

		if (present(wisdom_file)) then

			fn = 12
			open(unit=fn, file=wisdom_file, iostat = istat)

			if (istat /= 0 ) then
				print*, "Error --- PreCompute"
				print*, "Problem opening user defined FFTW wisdom file."
			endif

			call import_wisdom_from_file(isuccess, fn)
			if (isuccess == 0) then
				print*, "Local Wisdom file successfully read."
			else
				print*, "Local Wisdom file not read."
			endif

		endif

		first_call = 0

	endif

	upper = 1.0d0
	lower = -1.0d0

	n = NGLQSH(lmax)	! lmax is the maxium degree of the equation we
				! are going to integrate.

	call PreGLQ(lower, upper, n, zero, w)	! Determine Gauss Points and Weights.

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! 	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(norm)) then
				if (norm == 1) call PlmBar(pl, lmax, zero(i), csphase = phase, cnorm=cnormin)
				if (norm == 2) call PlmSchmidt(pl, lmax, zero(i), csphase = phase, cnorm=cnormin)
				if (norm == 3) call PLegendreA(pl, lmax, zero(i), csphase = phase)
				if (norm == 4) call PlmON(pl, lmax, zero(i), csphase = phase, cnorm=cnormin)
			else
				call PlmBar(pl, lmax, zero(i), csphase = phase, cnorm=cnormin)
			endif

			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.0d0)**(l-m)
					enddo
				enddo

			endif

		enddo

		if (present(norm)) then
			if (norm == 1) call PlmBar(pl, -1, zero(1), csphase = phase, cnorm=cnormin)
			if (norm == 2) call PlmSchmidt(pl, -1, zero(1), csphase = phase, cnorm=cnormin)
			if (norm == 4) call PlmON(pl, -1, zero(1), csphase = phase, cnorm=cnormin)
		else
			call PlmBar(pl, -1, zero(1), csphase = phase, cnorm=cnormin)
		endif

	endif

	deallocate(pl)

end subroutine PreCompute


MODULE FUN_xyRAY
!!#### PURPOSE
!! Determine a ray using:
!!   @ two points <PP>,
!!   @ a point and a vector <PV>, or
!!   @ a point and a unit vector <PU>.

!!#### EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp         !!((01-A-KND_IntrinsicTypes.f90))

!!#### EXTERNAL PROCEDURES
USE FUN_xyDIRECTION,ONLY: xyDIRECTION_V,xyDIRECTION_PP !!((04-B-FUN_xyDIRECTION.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyRAY_PP
 MODULE PROCEDURE xyRAY_PP_Rsp
 MODULE PROCEDURE xyRAY_PP_Rdp
END INTERFACE

INTERFACE xyRAY_PV
 MODULE PROCEDURE xyRAY_PV_Rsp
 MODULE PROCEDURE xyRAY_PV_Rdp
END INTERFACE

INTERFACE xyRAY_PU
 MODULE PROCEDURE xyRAY_PU_Rsp
 MODULE PROCEDURE xyRAY_PU_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyRAY_PP
PUBLIC :: xyRAY_PV
PUBLIC :: xyRAY_PU

CONTAINS

PURE FUNCTION xyRAY_PP_Rsp( P_a , P_b ) RESULT( xyRy )
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp          !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyRAY_PP.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyRAY_PP.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyRAY_PP_Rdp( P_a , P_b ) RESULT( xyRy )
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp          !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyRAY_PP.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyRAY_PP.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyRAY_PV_Rsp( P , V ) RESULT( xyRy )
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp          !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyRAY_PV.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyRAY_PV.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyRAY_PV_Rdp( P , V ) RESULT( xyRy )
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp          !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyRAY_PV.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyRAY_PV.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyRAY_PU_Rsp( P , U ) RESULT( xyRy )
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp          !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyRAY_PU.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyRAY_PU.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyRAY_PU_Rdp( P , U ) RESULT( xyRy )
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp          !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyRAY_PU.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyRAY_PU.f90.bdy"
!!--end--
END FUNCTION

END MODULE


c  File: drDTGrec.[f|for] contains drDTGrec, DTGfcn.
      program DRDTGREC
c>> 2001-07-16 DRDTGREC Krogh Added exponent 0 to some constants.
c>> 2001-05-24 DRDTGREC Krogh Minor change for making .f90 version.
c>> 2001-05-22 DRDTGREC Krogh Minor change for making .f90 version.
c>> 1997-07-01 DRDTGREC Krogh Reversed subscripts in B (CLL suggestion)
c>> 1997-06-19 DRDTGREC Krogh Minor changes to get proper C conversion.
c>> 1997-06-18 DRDTGREC CLL Added Bdry and MB to arg list of ?TGREC.
c              Also ZFILL has extended interpretation.
c>> 1996-03-04 DRDTGREC CLL
c>> 1996-02-02 DRDTGREC CLL
c>> 1995-09-26 DRDTGREC CLL Editing for inclusion into MATH77.
c>> 1991-11-20 DRDTGREC CLL  Minor editing. Adding use of ?SORTP.
c     C. L. LAWSON, JPL, 1977 MAR 2, CHANGED APR 7
c     C.L.L., 1979 MAR 3. MINOR CHANGES.
c
c     PORTABLE DEMONSTRATION DRIVER FOR SUBROUTINES THAT
c     CONSTRUCT A TRIANGULAR GRID AND THEN DO LOOK-UP AND INTERPOLATION
c     USING THE GRID.  THE INTERPOLATED SURFACE HAS C1 CONTINUITY.
c     ------------------------------------------------------------------
c  The amount of output by this program is controlled by a set of
c  logical variables.
c
c  PRTMAX  Print summary of max and RMS errors over the rectangular
c          grid.
c  PRTT  Call DTGPRG to print the initial X() and Y() data, the
c        pointers in TRIANG() defining the triangular grid, and the
c        pointers in Bdry() identifying the boundary of the triangular
c        grid.
c  PRTR  Print true and computed values and errors at all nodes of the
c        rectangular grid.
c  PRTTPD  Print the true and computed values of partial derivatives,
c          and the errors at all of the initial (x,y) points.
c     ------------------------------------------------------------------
c     THE CALL RELATIONSHIPS ARE AS FOLLOWS..
c
c     DRDTGREC           DEMONSTRATION DRIVER.
c        DTGGRD          CONSTRUCT TRIANGULAR GRID
c           ?SORTP       Sorting.   From the JPL Math77 library.
c           DTGANG       COMPUTE PSEUDOANGLES
c           ?TRSET       **     THESE FOUR SUBRS ARE USED TO STORE AND
c           DTGGET       **     FETCH POINTERS IN THE ARRAY TRIANG()
c           ?TRPUT       **     THAT DEFINES THE TRIANGULAR GRID.
c           ?TRSIZ       **
c           ?TRADJ       TEST AND MODIFY TRIANGULAR GRID
c             ?TRSET
c             DTGGET
c             ?TRPUT
c        DTGPRG          print DESCRIPTION OF TRIANGULAR GRID
c           DTGGET
c        DTGFCN          PROVIDE VALUES OF TEST functionS.
c        DTGPD           ESTIMATE PARTIAL DERIVATIVES AT GRID POINTS
c           DTGGET
c           ?TRMOR       FIND MORE PTS FOR PARTIAL DERIV ESTIMATION.
c              DTGGET
c           ?TRLS        WEIGHT,SCALE,STABILIZE,SOLVE FOR LOCAL L.S. FIT
c              ?ROTG     SETUP FOR GIVENS ROTATION. FROM THE BLAS.
c              ?ROT      APPLY GIVENS ROTATION. FROM THE BLAS.
c        DTGREC          BUILD RECTANGULAR GRID OF INTERPOLATED VALUES.
c           ?TRFI        Lookup and interpolation in triangular grid.
c              ?TRFND       LOOK-UP IN TRIANGULAR GRID
c                 DTGGET
c              ?TRC0        C0 INTERPOLATION IN A TRIANGLE
c              ?TRC1        C1 INTERPOLATION IN A TRIANGLE
c     ------------------------------------------------------------------
c
c     REMARKS ON DIMENSIONS..
c
c          IN TERMS OF THE PARAMETERS MP, MT, MB, MX, AND MY,
c     THE REQUIRED DIMENSIONS ARE..
c     double precision ZGRD(MX,MY), DZGRD(MX,MY,2)
c     double precision X(MP),Y(MP),Z(MP),DZ(2,MP),W(MP),XYLIM(4)
c     double precision DZZ(2),ERRDZ(2)
c     double precision DZTRUE(2,MP)
c     integer  IP(MP), TRIANG(MT), Bdry(4,MB)
c
c     (NOTE THAT SOME OF THESE DECLARED VARIABLES ARE ONLY
c      USED IN THIS DEMO DRIVER ITSELF AND ARE NOT ESSENTIAL
c      FOR THE GENERAL USE OF THE SUBROUTINES BEING DEMONSTRATED.)
c
c         MP DENOTES THE MAX NO. OF DATA POINTS TO BE HANDLED.
c          THE MAX NO. OF TRIANGLES CANNOT EXCEED 2*MP.  SINCE WE
c     STORE 6 POINTERS PER TRIANGLE IT FOLLOWS THAT MT CAN BE
c     SET AS         MT = (12*MP)
c          MB MUST BE LARGER BY 1 THAN THE MAX NO. OF BOUNDARY PTS
c     IN ANY SUBSET OF THE GIVEN SET OF (X,Y) DATA.   THE EXPECTED
c     NO. OF BNDRY PTS IN A RANDOM SAMPLE OF PTS FROM A UNIFORM
c     DISTRIBUTION ON DISC IS ABOUT  3.3 * (CUBE ROOT OF MP).
c     TWICE THIS EXPECTED VALUE PROVIDES AN ADEQUATE BOUND FOR
c     MOST CASES.  SETTING MB = MP+1 WOULD BE ABSOLUTELY SAFE
c     BUT LARGER THAN NECESSARY IN MOST CASES.
c          SETTING MB OR MT TOO SMALL WILL BE DETECTED AS ERROR
c     CONDITIONS  BY THE SUBROUTINES.
c          MX AND MY GIVE THE DIMENSIONS OF THE RECTANGULAR GRID ONTO
c     WHICH VALUES WILL BE INTERPOLATED UNDER CONTROL OF DTGREC.
c     ------------------------------------------------------------------
c--D replaces "?": DR?TGREC, ?TGGRD, ?TGPRG, ?TGFCN, ?TGPD, ?TGREC
c--&               ?TGGET,   ?TGANG
c     ------------------------------------------------------------------
      integer mb, mp, mt, mx, my
      parameter(mb= 16, mp= 28, mt= 336, mx= 5, my= 5)
      integer Bdry(4,mb), i, INFO(3), IP(mp), j, k, kf, kount
      integer ncont, np, nt, nx, ny, TRIANG(mt), filmod
      double precision delx, dely, DZ(2,mp), DZGRD(mx,my,2)
      double precision DZTRUE(2,mp), DZZ(2)
      double precision err, ERRDZ(2), errm, ERRMDZ(2)
      double precision rms, RMSDZ(2), sum1, SUM2(2)
      double precision W(mp), X(mp), xx, XYLIM(4),Y(mp), yy
      double precision Z(mp), zero, zfill, ZGRD(mx,my), zz
        parameter(zero = 0.0d0)
      logical   PRTMAX, PRTT, PRTR, PRTTPD, skip, WANTPD
      character title*75
      character       line1*56,       line2*19
      data PRTMAX, PRTT,PRTR,PRTTPD/.true., .true., .false., .false./
      data line1, line2/
     * '  ------------------------------------------------------',
     *                             '-------------------'/
      data X /
     *-0.76059D0,-0.02286D0,-0.44790D0, 0.15068D0,-0.87287D0,-0.23390D0,
     * 0.06093D0,-0.84142D0,-0.69173D0,-0.56613D0,-0.42243D0,-0.17249D0,
     *-0.06484D0, 0.48286D0,-0.88784D0, 0.10277D0, 0.69087D0,-0.84292D0,
     * 0.08784D0,-0.95068D0, 0.02496D0, 0.94973D0, 0.04588D0,-0.51667D0,
     *-0.77561D0, 0.90000D0,-0.70830D0,-0.40500D0 /
      data Y /
     *-0.31421D0, 0.75657D0, 0.14321D0, 0.42353D0,-0.62983D0, 0.12326D0,
     * 0.34054D0,-0.55144D0, 0.34158D0,-0.67143D0, 0.43087D0, 0.96081D0,
     *-0.68130D0, 0.12095D0,-0.10663D0, 0.29219D0, 0.31028D0, 0.12934D0,
     * 0.10709D0,-0.42307D0, 0.49895D0, 0.68597D0,-0.78215D0,-0.12362D0,
     *-0.88827D0,-0.60000D0,-0.88620D0, 0.08600D0 /
      data XYLIM / -1.0d0, +1.0d0, -1.0d0, +1.0d0 /
      data np, nx, ny / mp, mx, my /
      data wantpd / .true. /
c     ------------------------------------------------------------------
      write(*,'(a/a/)') ' Program DRDTGREC.  Demo driver for DTGREC,',
     * '         DTGGRD, DTGPD, etc.'
      call DTGGRD(X,Y,NP,IP,W,TRIANG,MT,Bdry,MB,NT, INFO)
      if (INFO(1) .NE. 0) then
         write(*,'(a,i5)')
     *      ' Error return from DTGGRD. INFO(1) =', INFO(1)
         stop
      endif
      if(PRTT) call DTGPRG(X,Y,NP,TRIANG,Bdry,INFO(2),NT)
c
      do 200 KF= 0, 4
         do 20 I=1,NP
               call DTGFCN(KF,X(I),Y(I),
     *            title, Z(I),DZTRUE(1,I),DZTRUE(2,I))
   20    continue
         write(*,'(/a,a/a/a,a)')
     *   line1,line2,   title,   line1,line2
         call DTGPD(X,Y,Z,DZ,NP, TRIANG, NT, IP)
         if (PRTTPD) then
            write(*,'(/a,a//a,a/41x,a/)')
     *      ' PARTIAL DERIVS ESTIMATED BY DTGPD AT THE GIVEN',
     *      ' DATA POINTS',
     *      '    I       X       Y       Z            ',
     *      'DZ1        DZTRUE1    ERR1',
     *      'DZ2        DZTRUE2    ERR2'
            do 50 I=1,NP
              do 40 J=1,2
                 ERRDZ(J) = DZ(J,I) - DZTRUE(J,I)
   40         continue
              write(*,'(1X,I4,3F8.4,2F15.6,E10.2/29x,2F15.6,E10.2)')
     *           I,X(I),Y(I),Z(I),(DZ(J,I), DZTRUE(J,I),
     *           ERRDZ(J), J=1,2)
   50       continue
         end if
c
         do 110 NCONT = 0, 1
         do 100 filmod = 0,1
              if(filmod .eq. 0) then
                 zfill = zero
              else
                 zfill = 999.0d0
              endif
         call DTGREC(X,Y,Z,DZ,NP,TRIANG,NT, Bdry, MB, XYLIM,NX,NY,
     *                  ZFILL,ZGRD,MX,MY, NCONT, WANTPD,DZGRD)
c
         if (PRTR .or. PRTMAX) then
            write(*,'(//5x,a,i1,a)')
     *       ' Using a C',ncont,' interpolation method.'
            if(zfill .eq. zero) then
                 write(*,'(5x,a/5x,a)')
     *       ' Assigning EXTRAPOLATED VALUES to points outside',
     *       ' the convex hull of the given data.'
              else
                 write(*,'(5x,a,f7.1,a/5x,a)')
     *       ' Assigning the value ',ZFILL,' to points outside',
     *       ' the convex hull of the given data.'
            endif

            if(PRTR) then
            write(*,'(/5x,a/7x,a//a,a/20x,a/20x,a/)')
     *       ' VALUES AND PARTIAL DERIVATIVES INTERPOLATED AT',
     *       ' LATTICE POINTS OF A RECTANGULAR GRID.',
     *       '   I   J     X     Y',
     *       '    Z_INTERP     Z_TRUE     Z_ERR',
     *       '  DZ1_INTERP   DZ1_TRUE   DZ1_ERR',
     *       '  DZ2_INTERP   DZ2_TRUE   DZ2_ERR'
            endif

            DELX =  (XYLIM(2)-XYLIM(1))/(NX-1)
            DELY =  (XYLIM(4)-XYLIM(3))/(NY-1)
            XX = XYLIM(1)
            SUM1 = 0.0d0
            SUM2(1) = 0.0d0
            SUM2(2) = 0.0d0
            KOUNT = 0
            ERRM = 0.0d0
            ERRMDZ(1) = 0.0d0
            ERRMDZ(2) = 0.0d0
            SKIP = .true.
            do 80 I=1,NX
               YY = XYLIM(3)
               do 70 J=1,NY
                  call DTGFCN(KF,  XX,YY, title, ZZ, DZZ(1), DZZ(2) )
                  if (ZGRD(I,J) .NE. ZFILL) then
                     ERR = ZGRD(I,J) - ZZ
                     if (ERRM .LT. ABS(ERR)) ERRM = ABS(ERR)
                     SUM1 = SUM1 + ERR**2
                     KOUNT = KOUNT + 1
                     do 60 K=1,2
                        ERRDZ(K)= DZGRD(I,J,K) - DZZ(K)
                        if (ERRMDZ(K) .LT. ABS(ERRDZ(K)))
     *                        ERRMDZ(K) = ABS(ERRDZ(K))
                        SUM2(K) = SUM2(K) + ERRDZ(K)**2
   60                continue
                     if(PRTR) then
                     write(*,
     *  '(1X,2I4,2F6.2,2F11.6,E10.2/21x,2F11.6,E10.2/21x,2F11.6,E10.2)')
     *                  I,J,XX,YY,
     *                  ZGRD(I,J), zz, err,
     *                  DZGRD(I,J,1), DZZ(1), errdz(1),
     *                  DZGRD(I,J,2), DZZ(2), errdz(2)
                     endif
                     skip = .true.
                  else
                     if(PRTR) then
                        if(skip) then
                           write(*,*) ' '
                           skip = .false.
                        endif
                     endif
                  end if
                     YY = YY+DELY
   70          continue
               XX = XX + DELX
   80       continue
            RMS = SQRT(SUM1 / KOUNT)
            do 90 K=1,2
               RMSDZ(K) = SQRT(SUM2(K) / KOUNT)
   90       continue
            if(PRTMAX) then
            write(*, '(/9x,a43/1x,3g17.6//9x,a43/1x,3g17.6/)')
     *        'MAX ERR Z       MAX ERR ZX       MAX ERR ZY',
     *         errm, errmdz(1), errmdz(2),
     *        'RMS ERR Z       RMS ERR ZX       RMS ERR ZY',
     *         RMS, rmsdz(1), rmsdz(2)
            endif
         end if
  100    continue
  110    continue
  200 continue
      end
c     ==================================================================
      subroutine DTGFCN  (KF,X,Y, TITLE, Z,ZX,ZY)
c>> 1995-09-26 CLL Editing for inclusion into MATH77.
c     C.L.Lawson, JPL, 1976 Dec 10.  Edited comments 1979 Mar 3.
c     This subr evaluates a function and its first partial derivs as
c     selected by KF.  KF can be from 0 to 4.
c     Input is KF, X, and Y.  Output is TITLE, Z, ZX, and ZY.
c     ------------------------------------------------------------------
c--S replaces "?": ?TRANG
c     ------------------------------------------------------------------
      integer KF
      double precision X,Y,Z,ZX,ZY
      character title*75
      character title1(0:4)*56, title2(0:4)*19
      integer i
      data (title1(i),title2(i),i=0,4) /
     * '  CONSTANT FUNCTION     Z = 2', ' ',
     * '  LINEAR FUNCTION       Z = ( 1 + 2*X + 3*Y ) / 6', ' ',
     * '  QUADRATIC FUNCTION    Z = ( -1 + 2*X - 3*Y + 4*X**2 - ',
     *                             'X*Y + 9*Y**2 ) / 10',
     * '  CUBIC FUNCTION    Z = ( 9*X**3 - 2*(X**2)*Y + 3*X*Y**2',
     *                             ' - 4 * Y**3 ) / 10',
     * '  EXPONENTIAL FUNCTION   Z = EXP( -2 * (X**2 + Y**2) )', ' '/
c     ------------------------------------------------------------------
      title = title1(kf) // title2(kf)
       if(kf .eq. 0) then
c                                  KF=0  CONSTANT FCN.
         Z=2.0d0
         ZX=0.0d0
         ZY=0.0d0
       elseif(kf .eq. 1) then
c                                  KF=1  LINEAR FCN.
         Z=(1.0d0 + 2.0d0*X + 3.0d0*Y) / 6.0d0
         ZX=2.0d0/6.0d0
         ZY=3.0d0/6.0d0
       elseif(kf .eq. 2) then
c                                  KF=2  QUADRATIC FCN.
         Z=(-1.0d0 + 2.0d0*X - 3.0d0*Y +4.0d0*X**2 -X*Y + 9.0d0*Y**2)*
     *       0.1d0
         ZX =(2.0d0 + 8.0d0*X -Y)* 0.1d0
         ZY =(-3.0d0 -X + 18.0d0*Y)* 0.1d0
       elseif(kf .eq. 3) then
c                                  KF=3  CUBIC FCN.
         Z=(9.0d0*X**3 - 2.0d0*(X**2)*Y + 3.0d0*X*Y**2 - 4.0d0*Y**3)*
     *       0.1d0
         ZX=(27.0d0*X**2 - 4.0d0*X*Y + 3.0d0*Y**2)* 0.1d0
         ZY=(-2.0d0*X**2 + 6.0d0*X*Y - 12.0d0*Y**2)* 0.1d0
       elseif(kf .eq. 4) then
c                                  KF=4  EXPONENTIAL FCN.
         Z=  EXP(-(X**2 + Y**2) * 2.0d0)
c
c              NOTE THAT THE INFLECTION POINT OF THIS FCN IN ANY
c              RADIAL DIRECTION FROM THE ORIGIN IS AT R = .5
c
         ZX= -4.0d0*X*Z
         ZY= -4.0d0*Y*Z
       endif
      return
      end


program ch0903
    ! Imperial Pints and US Pints
    implicit none

    integer :: fluid
    real :: imperial_pint
    real :: us_pint

    print *, ' US           Imperial'
    print *, ' pint(s)      pint(s)'
    do fluid = 1, 10
        imperial_pint = fluid*1.20095
        us_pint = fluid/1.20095
        print 100, imperial_pint, fluid, us_pint
    end do

100 format (' ', f5.2, '  ', i3, '   ', f5.2)
end program


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2018 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
!     S.W. Sloan, Adv.Eng.Software,1987,9(1),34-55.
!     Permission for use with the GPL license granted by Prof. Scott
!     Sloan on 17. Nov. 2013
!
      subroutine bsort(n,x,y,xmin,xmax,ymin,ymax,dmax,bin,list)
!
      implicit none
!
      integer list(*),bin(*),n,i,j,k,p,ndiv
!
      real*8 x(*),y(*),factx,facty,xmin,xmax,ymin,ymax,dmax
!
      ndiv=nint(real(n)**0.25d0)
      factx=real(ndiv)/((xmax-xmin)*1.01d0/dmax)
      facty=real(ndiv)/((ymax-ymin)*1.01d0/dmax)
      do 10 k=1,n
         p=list(k)
         i=int(y(p)*facty)
         j=int(x(p)*factx)
         if(mod(i,2).eq.0)then
            bin(p)=i*ndiv+j+1
         else
            bin(p)=(i+1)*ndiv-j
         end if
 10   continue
      call qsorti(n,list,bin)
      end


c>>   1988-11-22  DRISORT  Snyder  Initial code.
c
c     Test driver for ISORT and ISORTP.
c
c     Construct an array of 1000 random numbers using SRANUA.
c     Scale it onto 1..1,000,000 and convert to integers.
c     Sort it using ISORTP.
c     Check whether it is in order.
c     Sort it using ISORT.
c     Check whether it is in order.
c
      logical OK
      integer P(1:1000)
      real R(1:1000)
      integer I, V(1:1000)
c
c     Generate 1000 random numbers
      call sranua (r, 1000)
c     Scale them onto 1..1,000,000 and convert to integers.
      do 10 i = 1, 1000
         v(i) = 1000000*r(i)
10    continue
c     Sort them using ISORTP.  Assume the sort will work.
      ok=.TRUE.
      call isortp (v,1,1000,p)
c     Check the order.
      do 20 i = 2, 1000
         if (v(p(i)).lt.v(p(i-1))) ok=.FALSE.
20    continue
c     Print the results.
      if(ok)then
         print *,'ISORTP succeeded'
      else
         print *,'ISORTP failed'
      end if
c     Sort them using ISORT.  Assume the sort will work.
      ok=.TRUE.
      call isort (v,1,1000)
c     Check the order.
      do 30 i = 2, 1000
         if (v(i).lt.v(i-1)) ok=.FALSE.
30    continue
c     Print the results.
      if(ok)then
         print *,'ISORT succeeded'
      else
         print *,'ISORT failed'
      end if
c
      end


MODULE FUN_xyzCROSS
!!#### PURPOSE
!! Cross product for R^3 Cartesian geometry,
!
!!         C = xyzCROSS_VV( A , B )
!
!! where A, B, and C are vectors.

!!#### DETAILS
!! The cross product is only defined for two vectors A,B of the same
!! type-kinds.

!!#### EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyzCROSS_UU
 MODULE PROCEDURE xyzCROSS_UU_Rsp
 MODULE PROCEDURE xyzCROSS_UU_Rdp
END INTERFACE

INTERFACE xyzCROSS_VV
 MODULE PROCEDURE xyzCROSS_VV_Rsp
 MODULE PROCEDURE xyzCROSS_VV_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyzCROSS_UU
PUBLIC :: xyzCROSS_VV

CONTAINS

PURE FUNCTION xyzCROSS_VV_Rsp( V_a , V_b ) RESULT(xyzV)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyzCROSS_VV.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyzCROSS_VV.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyzCROSS_VV_Rdp( V_a , V_b ) RESULT(xyzV)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyzCROSS_VV.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyzCROSS_VV.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyzCROSS_UU_Rsp( U_a , U_b ) RESULT(xyzU)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyzCROSS_UU.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyzCROSS_UU.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyzCROSS_UU_Rdp( U_a , U_b ) RESULT(xyzU)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyzCROSS_UU.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyzCROSS_UU.f90.bdy"
!!--end--
END FUNCTION

END MODULE


module riemann_mod

use constants_mod

contains

!! HLLM Riemann solver
pure function xriemann(U_L,U_R) result(F)

    use equations_const_mod
    use equations_mod, only: pressure
    use setup_config_mod, only: kappa

    use equations_mod, only: flux => xflux

    real(dp), intent(in) :: U_L(N_VARS), U_R(N_VARS)
    real(dp)             :: F(N_VARS)

    real(dp) :: F_L(N_VARS), F_R(N_VARS)

    real(dp) :: c_L,c_R !! sound speed
    real(dp) :: H_L,H_R !! enthalpy
    real(dp) :: p_L,p_R !! pressure
    real(dp) :: S_L,S_R !! signal wave speed
    real(dp) :: V_L(N_DIMS),V_R(N_DIMS) !! velocities

    real(dp) :: alpha(N_DIMS)
    real(dp) :: roeVel(N_DIMS),roeH,roeC,roeDens
    real(dp) :: rx(N_VARS),ry(N_VARS),rz(N_VARS)

    real(dp) :: sqrtrho_L,sqrtrho_R,ssqrtrho,absvel
    real(dp), parameter :: beta = SQRT(0.5_dp*(kappa-1.0_dp)/kappa)

    real(dp) :: smooth

    !! velocities
    V_L = U_L(MOMX_VAR:MOMZ_VAR)/U_L(DENS_VAR)
    V_R = U_R(MOMX_VAR:MOMZ_VAR)/U_R(DENS_VAR)

    !! pressures
    p_L = pressure(U_L)
    p_R = pressure(U_R)

    !! sound speeds
    c_L = SQRT(kappa*p_L/U_L(DENS_VAR))
    c_R = SQRT(kappa*p_R/U_R(DENS_VAR))

    !! enthalpy
    H_L = (U_L(ENER_VAR) + p_L)/U_L(DENS_VAR)
    H_R = (U_R(ENER_VAR) + p_R)/U_R(DENS_VAR)

    !! auxiliaries
    SqrtRho_L = SQRT(U_L(DENS_VAR))
    SqrtRho_R = SQRT(U_R(DENS_VAR))
    sSqrtRho  = 1.0_dp/(SqrtRho_L+SqrtRho_R)

    !! Roe averages
    RoeVel    = (SqrtRho_R*V_R + SqrtRho_L*V_L) * sSqrtRho
    RoeH      = (SqrtRho_R*H_R + SqrtRho_L*H_L) * sSqrtRho
    absVel    = DOT_PRODUCT(RoeVel,RoeVel)
    RoeC      = SQRT((kappa-1.0_dp)*(RoeH-0.5_dp*absVel))
    RoeDens   = SQRT(U_L(DENS_VAR)*U_R(DENS_VAR))

    !! signal velocities
    S_L = MIN(RoeVel(X_DIR) - RoeC, V_L(X_DIR) - beta*c_L, 0.0_dp)
    S_R = MAX(RoeVel(X_DIR) + RoeC, V_R(X_DIR) + beta*c_R, 0.0_dp)

    if (S_L .ge. 0.0_dp) then
        F = flux(U_L)

    else if (S_R .le. 0.0_dp) then
        F = flux(U_R)

    else
        !! central fluxes
        F_L = flux(U_L)
        F_R = flux(U_R)

        !! wave strenghts
        alpha(X_DIR) = (U_R(DENS_VAR) - U_L(DENS_VAR))  - (p_R-p_L)/(RoeC*RoeC)
        alpha(Y_DIR) = RoeDens*(V_R(Y_DIR) - V_L(Y_DIR))
        alpha(Z_DIR) = RoeDens*(V_R(Z_DIR) - V_L(Z_DIR))

        !! eigenvectors
        rx = (/ 1.0_dp, RoeVel(X_DIR),  RoeVel(Y_DIR),  RoeVel(Z_DIR),  0.5*absVel     /)
        ry = (/ 0.0_dp, 0.0_dp,         1.0_dp,         0.0_dp,         RoeVel(Y_DIR)  /)
        rz = (/ 0.0_dp, 0.0_dp,         0.0_dp,         1.0_dp,         RoeVel(Z_DIR)  /)

        F = (S_R*F_L - S_L*F_R + S_L*S_R * &
                (U_R - U_L - RoeC/(RoeC + ABS(0.5_dp*(S_L+S_R))) * &
                    (rx*Alpha(X_DIR)+ry*Alpha(Y_DIR)+rz*Alpha(Z_DIR))))/(S_R-S_L)

        !! alleviate carbuncles at sharp grid-aligned shock fronts
        smooth = SQRT(abs(p_L - p_R)/(p_L + p_R))
        F = F + smooth * ((S_R*F_L - S_L*F_R + S_L*S_R*(U_R - U_L)) / (S_R - S_L) - F)
    end if

end function

pure function yriemann(uL,uR) result(sf)

    use equations_const_mod

    real(dp), intent(in) :: uL(N_VARS), uR(N_VARS)
    real(dp)             :: sf(N_VARS)

    real(dp) :: ruL(N_VARS), ruR(N_VARS), rf(N_VARS) !! rotated

    ruL(DENS_VAR) = uL(DENS_VAR)
    ruL(MOMX_VAR) = uL(MOMY_VAR)
    ruL(MOMY_VAR) = uL(MOMZ_VAR)
    ruL(MOMZ_VAR) = uL(MOMX_VAR)
    ruL(ENER_VAR) = uL(ENER_VAR)

    ruR(DENS_VAR) = uR(DENS_VAR)
    ruR(MOMX_VAR) = uR(MOMY_VAR)
    ruR(MOMY_VAR) = uR(MOMZ_VAR)
    ruR(MOMZ_VAR) = uR(MOMX_VAR)
    ruR(ENER_VAR) = uR(ENER_VAR)

    rf = xriemann(ruL,ruR)

    sf(DENS_VAR) = rf(DENS_VAR)
    sf(MOMX_VAR) = rf(MOMZ_VAR)
    sf(MOMY_VAR) = rf(MOMX_VAR)
    sf(MOMZ_VAR) = rf(MOMY_VAR)
    sf(ENER_VAR) = rf(ENER_VAR)

end function

pure function zriemann(uL,uR) result(sf)

    use equations_const_mod

    real(dp), intent(in) :: uL(N_VARS), uR(N_VARS)
    real(dp)             :: sf(N_VARS)

    real(dp) :: ruL(N_VARS), ruR(N_VARS), rf(N_VARS) !! rotated

    ruL(DENS_VAR) = uL(DENS_VAR)
    ruL(MOMX_VAR) = uL(MOMZ_VAR)
    ruL(MOMY_VAR) = uL(MOMX_VAR)
    ruL(MOMZ_VAR) = uL(MOMY_VAR)
    ruL(ENER_VAR) = uL(ENER_VAR)

    ruR(DENS_VAR) = uR(DENS_VAR)
    ruR(MOMX_VAR) = uR(MOMZ_VAR)
    ruR(MOMY_VAR) = uR(MOMX_VAR)
    ruR(MOMZ_VAR) = uR(MOMY_VAR)
    ruR(ENER_VAR) = uR(ENER_VAR)

    rf = xriemann(ruL,ruR)

    sf(DENS_VAR) = rf(DENS_VAR)
    sf(MOMX_VAR) = rf(MOMY_VAR)
    sf(MOMY_VAR) = rf(MOMZ_VAR)
    sf(MOMZ_VAR) = rf(MOMX_VAR)
    sf(ENER_VAR) = rf(ENER_VAR)

end function

end module


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1997  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  function maxwell  --  Maxwell-Boltzmann distribution value  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "maxwell" returns a speed in Angstroms/picosecond randomly
c     selected from a 3-D Maxwell-Boltzmann distribution for the
c     specified particle mass and system temperature
c
c     literature reference:
c
c     P. W. Atkins, "Physical Chemistry, 4th Edition", W. H. Freeman,
c     New York, 1990; see section 24.2 for general discussion
c
c
      function maxwell (mass,temper)
      implicit none
      include 'units.i'
      real*8 maxwell
      real*8 mass,temper
      real*8 rho,beta
      real*8 random,erfinv
      real*8 xspeed,yspeed
      real*8 zspeed
      external erfinv
c
c
c     set normalization factor for cumulative velocity distribution
c
      beta = sqrt(mass / (2.0d0*boltzmann*temper))
c
c     pick a randomly distributed velocity along each of three axes
c
      rho = random ()
      xspeed = erfinv(rho) / beta
      rho = random ()
      yspeed = erfinv(rho) / beta
      rho = random ()
      zspeed = erfinv(rho) / beta
c
c     set the final value of the particle speed in 3-dimensions
c
      maxwell = sqrt(xspeed**2 + yspeed**2 + zspeed**2)
      return
      end


C=======================================================================
C  PETPNO, Subroutine, N.B. Pickering
C  Calculates FAO-24 Penman potential evapotranspiration (without
C  correction)--grass reference.
!-----------------------------------------------------------------------
C  REVISION HISTORY
C  02/19/1992 NBP Written
C  11/04/1993 NBP Renamed routine PET to PETPEN.  Changed XLAI to XHLAI
C               Added XHLAI .LE. 0.0 statement.
C  05/13/1994 NBP Converted all vapor pressures to Pa.  Rearranged.
C  09/16/1994 NBP Added limits to prevent EO and ES (PE) < 0.
C  10/17/1997 CHP Updated for modular format.
C  09/01/1999 GH  Incorporated into CROPGRO
C  05/06/2002 WMB Fixed Stefan-Boltzmann constant
!  07/24/2006 CHP Use MSALB instead of SALB (includes mulch and soil
!                 water effects on albedo)
!-----------------------------------------------------------------------
!  Called from:   PET
!  Calls:         None
C=======================================================================
      SUBROUTINE PETPNO(
     &    CLOUDS, MSALB, SRAD, TAVG, TDEW,                !Input
     &    TMAX, TMIN, WINDSP, XHLAI,                      !Input
     &    EO)                                             !Output
!-----------------------------------------------------------------------
      IMPLICIT NONE
!-----------------------------------------------------------------------
!     INPUT VARIABLES:
      REAL CLOUDS, MSALB, SRAD, TAVG, TDEW, TMAX, TMIN,
     &        WINDSP, XHLAI
!-----------------------------------------------------------------------
!     OUTPUT VARIABLES:
      REAL EO
!-----------------------------------------------------------------------
!     LOCAL VARIABLES:
      REAL ALBEDO, EAIR, ESAT, G, LHVAP, PSYCON, RADB,
     &  RNET, RNETMG, S, TK4,
     &  VHCAIR, VPD, WFNFAO, DAIR, RT
      REAL SHAIR, PATM, SBZCON

      PARAMETER (SHAIR = 1005.0)
      PARAMETER (PATM = 101300.0)
!      PARAMETER (SBZCON=4.093E-9)   !(MJ/m2/d)
      PARAMETER (SBZCON=4.903E-9)   !(MJ/K4/m2/d) fixed constant 5/6/02
!-----------------------------------------------------------------------
!     FUNCTION SUBROUTINES:
      REAL VPSLOP, VPSAT      !Found in file HMET.for

C-----------------------------------------------------------------------
C     Compute air properties.

C      ESAT = VPSAT(VPSLOP(VPSAT(TMIN))) + VPSLOP(VPSLOP(VPSAT(TMAX)))

      LHVAP = (2501.0-2.373*TAVG) * 1000.0                 ! J/kg
      PSYCON = SHAIR * PATM / (0.622*LHVAP)                ! Pa/K
      ESAT = (VPSAT(TMAX)+VPSAT(TMIN)) / 2.0               ! Pa
      EAIR = VPSAT(TDEW)                                   ! Pa
      VPD = ESAT - EAIR                                    ! Pa
      S = (VPSLOP(TMAX)+VPSLOP(TMIN)) / 2.0                ! Pa/K
      RT = 8.314 * (TAVG + 273.0)                             ! N.m/mol
      DAIR = 0.1 * 18.0 / RT * ((PATM  -EAIR)/0.622 + EAIR)   ! kg/m3
      VHCAIR = DAIR * SHAIR    !not used                      ! J/m3

C     Convert windspeed to 2 m reference height.
!     Do this conversion in WEATHR and send out 2m windspeed
!     CHP 11/26/01
!      WIND2 = WINDSP * (2.0/WINDHT)**0.2

C     Calculate net radiation (MJ/m2/d).  Constants for RADB from
C     Jensen et al (1989) for semi-humid conditions.  The value 0.005
C     converts the value 0.158 from kPa to Pa.

      G = 0.0
      IF (XHLAI .LE. 0.0) THEN
        ALBEDO = MSALB
      ELSE
        ALBEDO = 0.23-(0.23-MSALB)*EXP(-0.75*XHLAI)
      ENDIF

      TK4 = ((TMAX+273.)**4+(TMIN+273.)**4) / 2.0
      RADB = SBZCON * TK4 * (0.4 - 0.005 * SQRT(EAIR)) *
     &        (1.1 * (1. - CLOUDS) - 0.1)
      RNET= (1.0-ALBEDO)*SRAD - RADB

C     Compute ETP using the FAO wind function.  The multipliers for WNDFAO
C     are 1000 times smaller than in Jensen et al (1979) to convert VPD in
C     Pa to kPa. Equation for RNETMG converts from MJ/m2/d to mm/day.

!      WFNFAO = 0.0027 * (1.0+0.01*WIND2)
      WFNFAO = 0.0027 * (1.0+0.01*WINDSP)
      RNETMG = (RNET-G) / LHVAP * 1.0E6
      EO = (S*RNETMG + PSYCON*WFNFAO*VPD) / (S+PSYCON)
!###  EO = MAX(EO,0.0)   !gives error in DECRAT_C
      EO = MAX(EO,0.0001)

!-----------------------------------------------------------------------
      RETURN
      END SUBROUTINE PETPNO

C=======================================================================
C  VPSAT, Real Function, N.B. Pickering, 4/1/90
C  Calculates saturated vapor pressure of air (Tetens, 1930).
!-----------------------------------------------------------------------
!  Called by: CANPET, HMET, VPSLOP, PETPEN
!  Calls:     None
!-----------------------------------------------------------------------
C  Input : T (C)
C  Output: VPSAT (Pa)
C=======================================================================
      REAL FUNCTION VPSAT(T)

      IMPLICIT NONE
      REAL T

      VPSAT = 610.78 * EXP(17.269*T/(T+237.30))

      RETURN
      END FUNCTION VPSAT
C=======================================================================
! VPSAT Variables
!-----------------------------------------------------------------------
! T     Air temperature (oC)
! VPSAT Saturated vapor pressure of air (Pa)
C=======================================================================

C=======================================================================
C  VPSLOP, Real Function, N.B. Pickering, 4/1/90
C  Calculates slope of saturated vapor pressure versus temperature curve
C  using Classius-Clapeyron equation (see Brutsaert, 1982 p. 41)
!-----------------------------------------------------------------------
!  Called by: ETSOLV, PETPEN, TRATIO
!  Calls:     VPSAT
!-----------------------------------------------------------------------
C  Input : T (C)
C  Output: VPSLOP
C=======================================================================
      REAL FUNCTION VPSLOP(T)

      IMPLICIT NONE

      REAL T,VPSAT

C     dEsat/dTempKel = MolWeightH2O * LatHeatH2O * Esat / (Rgas * TempKel^2)
      VPSLOP = 18.0 * (2501.0-2.373*T) * VPSAT(T) / (8.314*(T+273.0)**2)

      RETURN
      END FUNCTION VPSLOP
C=======================================================================
! VPSLOP variables
!-----------------------------------------------------------------------
! T      Air temperature (oC)
! VPSAT  Saturated vapor pressure of air (Pa)
! VPSLOP Slope of saturated vapor pressure versus temperature curve
C=======================================================================


!======================================================================!
  real function UserUPlus(grid, y)
!----------------------------------------------------------------------!
! Prescribes initial velocity profile for channel flow at ReTau=180    !
! This function gives centerline velocity: Uc = 18.0412006             !
!----------------------------------------------------------------------!
  implicit none
!-----------------------------[Arguments]------------------------------!
  real :: y
!======================================================================!
!   Wall is at y=0, and centerline at y=1                              !
!----------------------------------------------------------------------!

  UserUPlus =                                                       &
   -4.555442e+003  * y**9  +  1.902458e+004  * y**8                 &
   -3.108515e+004  * y**7  +  2.331028e+004  * y**6                 &
   -4.723039e+003  * y**5  -  4.867699e+003  * y**4                 &
   +3.999634e+003  * y**3  -  1.297551e+003  * y**2                 &
   +2.125647e+002  * y**1  -  1.353124e-001

  end function UserUPlus