C
C     file hwsssp.f
C
      SUBROUTINE HWSSSP (TS,TF,M,MBDCND,BDTS,BDTF,PS,PF,N,NBDCND,BDPS,
     1                   BDPF,ELMBDA,F,IDIMF,PERTRB,IERROR,W)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
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
C DIMENSION OF           BDTS(N+1),    BDTF(N+1), BDPS(M+1), BDPF(M+1),
C ARGUMENTS              F(IDIMF,N+1), W(SEE ARGUMENT LIST)
C
C LATEST REVISION        NOVEMBER 1988
C
C PURPOSE                SOLVES A FINITE DIFFERENCE APPROXIMATION TO
C                        THE HELMHOLTZ EQUATION IN SPHERICAL
C                        COORDINATES AND ON THE SURFACE OF THE UNIT
C                        SPHERE (RADIUS OF 1).  THE EQUATION IS
C
C                          (1/SIN(THETA))(D/DTHETA)(SIN(THETA)
C                          (DU/DTHETA)) + (1/SIN(THETA)**2)(D/DPHI)
C                          (DU/DPHI)  + LAMBDA*U = F(THETA,PHI)
C
C                        WHERE THETA IS COLATITUDE AND PHI IS
C                        LONGITUDE.
C
C USAGE                  CALL HWSSSP (TS,TF,M,MBDCND,BDTS,BDTF,PS,PF,
C                                     N,NBDCND,BDPS,BDPF,ELMBDA,F,
C                                     IDIMF,PERTRB,IERROR,W)
C
C ARGUMENTS
C ON INPUT               TS,TF
C
C                          THE RANGE OF THETA (COLATITUDE), I.E.,
C                          TS .LE. THETA .LE. TF. TS MUST BE LESS
C                          THAN TF.  TS AND TF ARE IN RADIANS.
C                          A TS OF ZERO CORRESPONDS TO THE NORTH
C                          POLE AND A TF OF PI CORRESPONDS TO
C                          THE SOUTH POLE.
C
C                          * * * IMPORTANT * * *
C
C                          IF TF IS EQUAL TO PI THEN IT MUST BE
C                          COMPUTED USING THE STATEMENT
C                          TF = PIMACH(DUM). THIS INSURES THAT TF
C                          IN THE USER'S PROGRAM IS EQUAL TO PI IN
C                          THIS PROGRAM WHICH PERMITS SEVERAL TESTS
C                          OF THE INPUT PARAMETERS THAT OTHERWISE
C                          WOULD NOT BE POSSIBLE.
C
C
C                        M
C                          THE NUMBER OF PANELS INTO WHICH THE
C                          INTERVAL (TS,TF) IS SUBDIVIDED.
C                          HENCE, THERE WILL BE M+1 GRID POINTS IN THE
C                          THETA-DIRECTION GIVEN BY
C                          THETA(I) = (I-1)DTHETA+TS FOR
C                          I = 1,2,...,M+1, WHERE
C                          DTHETA = (TF-TS)/M IS THE PANEL WIDTH.
C                          M MUST BE GREATER THAN 5
C
C                        MBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITION
C                          AT THETA = TS AND THETA = TF.
C
C                          = 1  IF THE SOLUTION IS SPECIFIED AT
C                               THETA = TS AND THETA = TF.
C                          = 2  IF THE SOLUTION IS SPECIFIED AT
C                               THETA = TS AND THE DERIVATIVE OF
C                               THE SOLUTION WITH RESPECT TO THETA IS
C                               SPECIFIED AT THETA = TF
C                               (SEE NOTE 2 BELOW).
C                          = 3  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO THETA IS SPECIFIED
C                               SPECIFIED AT THETA = TS AND
C                               THETA = TF (SEE NOTES 1,2 BELOW).
C                          = 4  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO THETA IS SPECIFIED
C                               AT THETA = TS (SEE NOTE 1 BELOW)
C                               AND THE SOLUTION IS SPECIFIED AT
C                               THETA = TF.
C                          = 5  IF THE SOLUTION IS UNSPECIFIED AT
C                               THETA = TS = 0 AND THE SOLUTION
C                               IS SPECIFIED AT THETA = TF.
C                          = 6  IF THE SOLUTION IS UNSPECIFIED AT
C                               THETA = TS = 0 AND THE DERIVATIVE
C                               OF THE SOLUTION WITH RESPECT TO THETA
C                               IS SPECIFIED AT THETA = TF
C                               (SEE NOTE 2 BELOW).
C                          = 7  IF THE SOLUTION IS SPECIFIED AT
C                               THETA = TS AND THE SOLUTION IS
C                               IS UNSPECIFIED AT THETA = TF = PI.
C                          = 8  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO THETA IS SPECIFIED
C                               AT THETA = TS (SEE NOTE 1 BELOW) AND
C                               THE SOLUTION IS UNSPECIFIED AT
C                               THETA = TF = PI.
C                          = 9  IF THE SOLUTION IS UNSPECIFIED AT
C                               THETA = TS = 0 AND THETA = TF = PI.
C
C                          NOTES:
C                          IF TS = 0, DO NOT USE MBDCND = 3,4, OR 8,
C                          BUT INSTEAD USE MBDCND = 5,6, OR 9  .
C
C                          IF TF = PI, DO NOT USE MBDCND = 2,3, OR 6,
C                          BUT INSTEAD USE MBDCND = 7,8, OR 9  .
C
C                        BDTS
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT
C                          SPECIFIES THE VALUES OF THE DERIVATIVE OF
C                          THE SOLUTION WITH RESPECT TO THETA AT
C                          THETA = TS.  WHEN MBDCND = 3,4, OR 8,
C
C                          BDTS(J) = (D/DTHETA)U(TS,PHI(J)),
C                          J = 1,2,...,N+1  .
C
C                          WHEN MBDCND HAS ANY OTHER VALUE, BDTS IS
C                          A DUMMY VARIABLE.
C
C                        BDTF
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N+1
C                          THAT SPECIFIES THE VALUES OF THE DERIVATIVE
C                          OF THE SOLUTION WITH RESPECT TO THETA AT
C                          THETA = TF.  WHEN MBDCND = 2,3, OR 6,
C
C                          BDTF(J) = (D/DTHETA)U(TF,PHI(J)),
C                          J = 1,2,...,N+1  .
C
C                          WHEN MBDCND HAS ANY OTHER VALUE, BDTF IS
C                          A DUMMY VARIABLE.
C
C                        PS,PF
C                          THE RANGE OF PHI (LONGITUDE), I.E.,
C                          PS .LE. PHI .LE. PF.  PS MUST BE LESS
C                          THAN PF.  PS AND PF ARE IN RADIANS.
C                          IF PS = 0 AND PF = 2*PI, PERIODIC
C                          BOUNDARY CONDITIONS ARE USUALLY PRESCRIBED.
C
C                          * * * IMPORTANT * * *
C
C                          IF PF IS EQUAL TO 2*PI THEN IT MUST BE
C                          COMPUTED USING THE STATEMENT
C                          PF = 2.*PIMACH(DUM). THIS INSURES THAT
C                          PF IN THE USERS PROGRAM IS EQUAL TO
C                          2*PI IN THIS PROGRAM WHICH PERMITS TESTS
C                          OF THE INPUT PARAMETERS THAT OTHERWISE
C                          WOULD NOT BE POSSIBLE.
C
C                        N
C                          THE NUMBER OF PANELS INTO WHICH THE
C                          INTERVAL (PS,PF) IS SUBDIVIDED.
C                          HENCE, THERE WILL BE N+1 GRID POINTS
C                          IN THE PHI-DIRECTION GIVEN BY
C                          PHI(J) = (J-1)DPHI+PS  FOR
C                          J = 1,2,...,N+1, WHERE
C                          DPHI = (PF-PS)/N IS THE PANEL WIDTH.
C                          N MUST BE GREATER THAN 4
C
C                        NBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITION
C                          AT PHI = PS AND PHI = PF.
C
C                          = 0  IF THE SOLUTION IS PERIODIC IN PHI,
C                               I.U., U(I,J) = U(I,N+J).
C                          = 1  IF THE SOLUTION IS SPECIFIED AT
C                               PHI = PS AND PHI = PF
C                               (SEE NOTE BELOW).
C                          = 2  IF THE SOLUTION IS SPECIFIED AT
C                               PHI = PS (SEE NOTE BELOW)
C                               AND THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO PHI IS SPECIFIED
C                               AT PHI = PF.
C                          = 3  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO PHI IS SPECIFIED
C                               AT PHI = PS AND PHI = PF.
C                          = 4  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO PHI IS SPECIFIED
C                               AT PS AND THE SOLUTION IS SPECIFIED
C                               AT PHI = PF
C
C                          NOTE:
C                          NBDCND = 1,2, OR 4 CANNOT BE USED WITH
C                          MBDCND = 5,6,7,8, OR 9.  THE FORMER INDICATES
C                          THAT THE SOLUTION IS SPECIFIED AT A POLE, THE
C                          LATTER INDICATES THAT THE SOLUTION IS NOT
C                          SPECIFIED.  USE INSTEAD  MBDCND = 1 OR 2.
C
C                        BDPS
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT
C                          SPECIFIES THE VALUES OF THE DERIVATIVE
C                          OF THE SOLUTION WITH RESPECT TO PHI AT
C                          PHI = PS.  WHEN NBDCND = 3 OR 4,
C
C                            BDPS(I) = (D/DPHI)U(THETA(I),PS),
C                            I = 1,2,...,M+1  .
C
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDPS IS
C                          A DUMMY VARIABLE.
C
C                        BDPF
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT
C                          SPECIFIES THE VALUES OF THE DERIVATIVE
C                          OF THE SOLUTION WITH RESPECT TO PHI AT
C                          PHI = PF.  WHEN NBDCND = 2 OR 3,
C
C                            BDPF(I) = (D/DPHI)U(THETA(I),PF),
C                            I = 1,2,...,M+1  .
C
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDPF IS
C                          A DUMMY VARIABLE.
C
C                        ELMBDA
C                          THE CONSTANT LAMBDA IN THE HELMHOLTZ
C                          EQUATION.  IF LAMBDA .GT. 0, A SOLUTION
C                          MAY NOT EXIST.  HOWEVER, HWSSSP WILL
C                          ATTEMPT TO FIND A SOLUTION.
C
C                        F
C                          A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE
C                          VALUE OF THE RIGHT SIDE OF THE HELMHOLTZ
C                          EQUATION AND BOUNDARY VALUES (IF ANY).
C                          F MUST BE DIMENSIONED AT LEAST (M+1)*(N+1).
C
C                          ON THE INTERIOR, F IS DEFINED AS FOLLOWS:
C                          FOR I = 2,3,...,M AND J = 2,3,...,N
C                          F(I,J) = F(THETA(I),PHI(J)).
C
C                          ON THE BOUNDARIES F IS DEFINED AS FOLLOWS:
C                          FOR J = 1,2,...,N+1 AND I = 1,2,...,M+1
C
C                          MBDCND   F(1,J)            F(M+1,J)
C                          ------   ------------      ------------
C
C                            1      U(TS,PHI(J))      U(TF,PHI(J))
C                            2      U(TS,PHI(J))      F(TF,PHI(J))
C                            3      F(TS,PHI(J))      F(TF,PHI(J))
C                            4      F(TS,PHI(J))      U(TF,PHI(J))
C                            5      F(0,PS)           U(TF,PHI(J))
C                            6      F(0,PS)           F(TF,PHI(J))
C                            7      U(TS,PHI(J))      F(PI,PS)
C                            8      F(TS,PHI(J))      F(PI,PS)
C                            9      F(0,PS)           F(PI,PS)
C
C                          NBDCND   F(I,1)            F(I,N+1)
C                          ------   --------------    --------------
C
C                            0      F(THETA(I),PS)    F(THETA(I),PS)
C                            1      U(THETA(I),PS)    U(THETA(I),PF)
C                            2      U(THETA(I),PS)    F(THETA(I),PF)
C                            3      F(THETA(I),PS)    F(THETA(I),PF)
C                            4      F(THETA(I),PS)    U(THETA(I),PF)
C
C                          NOTE:
C                          IF THE TABLE CALLS FOR BOTH THE SOLUTION U
C                          AND THE RIGHT SIDE F AT A CORNER THEN THE
C                          SOLUTION MUST BE SPECIFIED.
C
C                        IDIMF
C                          THE ROW (OR FIRST) DIMENSION OF THE ARRAY
C                          F AS IT APPEARS IN THE PROGRAM CALLING
C                          HWSSSP.  THIS PARAMETER IS USED TO SPECIFY
C                          THE VARIABLE DIMENSION OF F. IDIMF MUST BE
C                          AT LEAST M+1  .
C
C                        W
C                          A ONE-DIMENSIONAL ARRAY THAT MUST BE
C                          PROVIDED BY THE USER FOR WORK SPACE.
C                          W MAY REQUIRE UP TO
C                          4*(N+1)+(16+INT(LOG2(N+1)))(M+1) LOCATIONS
C                          THE ACTUAL NUMBER OF LOCATIONS USED IS
C                          COMPUTED BY HWSSSP AND IS OUTPUT IN
C                          LOCATION W(1). INT( ) DENOTES THE
C                          FORTRAN INTEGER FUNCTION.
C
C
C ON OUTPUT              F
C                          CONTAINS THE SOLUTION U(I,J) OF THE FINITE
C                          DIFFERENCE APPROXIMATION FOR THE GRID POINT
C                          (THETA(I),PHI(J)),  I = 1,2,...,M+1  AND
C                          J = 1,2,...,N+1  .
C
C                        PERTRB
C                          IF ONE SPECIFIES A COMBINATION OF PERIODIC,
C                          DERIVATIVE OR UNSPECIFIED BOUNDARY
C                          CONDITIONS FOR A POISSON EQUATION
C                          (LAMBDA = 0), A SOLUTION MAY NOT EXIST.
C                          PERTRB IS A CONSTANT, CALCULATED AND
C                          SUBTRACTED FROM F, WHICH ENSURES THAT A
C                          SOLUTION EXISTS.  HWSSSP THEN COMPUTES
C                          THIS SOLUTION, WHICH IS A LEAST SQUARES
C                          SOLUTION TO THE ORIGINAL APPROXIMATION.
C                          THIS SOLUTION IS NOT UNIQUE AND IS
C                          UNNORMALIZED. THE VALUE OF PERTRB SHOULD
C                          BE SMALL COMPARED TO THE RIGHT SIDE F.
C                          OTHERWISE , A SOLUTION IS OBTAINED TO AN
C                          ESSENTIALLY DIFFERENT PROBLEM. THIS
C                          COMPARISON SHOULD ALWAYS BE MADE TO INSURE
C                          THAT A MEANINGFUL SOLUTION HAS BEEN
C                          OBTAINED
C
C                        IERROR
C                          AN ERROR FLAG THAT INDICATES INVALID INPUT
C                          PARAMETERS.  EXCEPT FOR NUMBERS 0 AND 8,
C                          A SOLUTION IS NOT ATTEMPTED.
C
C                          = 0  NO ERROR
C                          = 1  TS.LT.0 OR TF.GT.PI
C                          = 2  TS.GE.TF
C                          = 3  MBDCND.LT.1 OR MBDCND.GT.9
C                          = 4  PS.LT.0 OR PS.GT.PI+PI
C                          = 5  PS.GE.PF
C                          = 6  N.LT.5
C                          = 7  M.LT.5
C                          = 8  NBDCND.LT.0 OR NBDCND.GT.4
C                          = 9  ELMBDA.GT.0
C                          = 10 IDIMF.LT.M+1
C                          = 11 NBDCND EQUALS 1,2 OR 4 AND MBDCND.GE.5
C                          = 12 TS.EQ.0 AND MBDCND EQUALS 3,4 OR 8
C                          = 13 TF.EQ.PI AND MBDCND EQUALS 2,3 OR 6
C                          = 14 MBDCND EQUALS 5,6 OR 9 AND TS.NE.0
C                          = 15 MBDCND.GE.7 AND TF.NE.PI
C
C                          SINCE THIS IS THE ONLY MEANS OF INDICATING
C                          A POSSIBLY INCORRECT CALL TO HWSSSP, THE
C                          USER SHOULD TEST IERROR AFTER A CALL.
C
C                        W
C                          CONTAINS INTERMEDIATE VALUES THAT MUST NOT
C                          BE DESTROYED IF HWSSSP WILL BE CALLED AGAIN
C                          WITH INTL = 1. W(1) CONTAINS THE REQUIRED
C                          LENGTH OF W .
C
C SPECIAL CONDITIONS     NONE
C
C I/O                    NONE
C
C PRECISION              SINGLE
C
C REQUIRED LIBRARY       GENBUN, GNBNAUX, AND COMF
C FILES                  FROM FISHPACK
C
C LANGUAGE               FORTRAN
C
C HISTORY                WRITTEN BY ROLAND SWEET AT NCAR IN THE LATE
C                        1970'S.  RELEASED ON NCAR'S PUBLIC SOFTWARE
C                        LIBRARIES IN JANUARY 1980.
C
C PORTABILITY            FORTRAN 77
C
C ALGORITHM              THE ROUTINE DEFINES THE FINITE DIFFERENCE
C                        EQUATIONS, INCORPORATES BOUNDARY DATA, AND
C                        ADJUSTS THE RIGHT SIDE OF SINGULAR SYSTEMS
C                        AND THEN CALLS GENBUN TO SOLVE THE SYSTEM.
C
C TIMING                 FOR LARGE  M AND N, THE OPERATION COUNT
C                        IS ROUGHLY PROPORTIONAL TO
C                          M*N*(LOG2(N)
C                        BUT ALSO DEPENDS ON INPUT PARAMETERS NBDCND
C                        AND MBDCND.
C
C ACCURACY               THE SOLUTION PROCESS EMPLOYED RESULTS IN A LOSS
C                        OF NO MORE THAN THREE SIGNIFICANT DIGITS FOR N
C                        AND M AS LARGE AS 64.  MORE DETAILS ABOUT
C                        ACCURACY CAN BE FOUND IN THE DOCUMENTATION FOR
C                        SUBROUTINE GENBUN WHICH IS THE ROUTINE THAT
C                        SOLVES THE FINITE DIFFERENCE EQUATIONS.
C
C REFERENCES             P. N. SWARZTRAUBER, "THE DIRECT SOLUTION OF
C                        THE DISCRETE POISSON EQUATION ON THE SURFACE OF
C                        A SPHERE", S.I.A.M. J. NUMER. ANAL.,15(1974),
C                        PP 212-215.
C
C                        SWARZTRAUBER,P. AND R. SWEET, "EFFICIENT
C                        FORTRAN SUBPROGRAMS FOR THE SOLUTION OF
C                        ELLIPTIC EQUATIONS", NCAR TN/IA-109, JULY,
C                        1975, 138 PP.
C***********************************************************************
      DIMENSION       F(IDIMF,1) ,BDTS(*)    ,BDTF(*)    ,BDPS(*)    ,
     1                BDPF(*)    ,W(*)
C
      NBR = NBDCND+1
      PI = PIMACH(DUM)
      TPI = 2.*PI
      IERROR = 0
      IF (TS.LT.0. .OR. TF.GT.PI) IERROR = 1
      IF (TS .GE. TF) IERROR = 2
      IF (MBDCND.LT.1 .OR. MBDCND.GT.9) IERROR = 3
      IF (PS.LT.0. .OR. PF.GT.TPI) IERROR = 4
      IF (PS .GE. PF) IERROR = 5
      IF (N .LT. 5) IERROR = 6
      IF (M .LT. 5) IERROR = 7
      IF (NBDCND.LT.0 .OR. NBDCND.GT.4) IERROR = 8
      IF (ELMBDA .GT. 0.) IERROR = 9
      IF (IDIMF .LT. M+1) IERROR = 10
      IF ((NBDCND.EQ.1 .OR. NBDCND.EQ.2 .OR. NBDCND.EQ.4) .AND.
     1    MBDCND.GE.5) IERROR = 11
      IF (TS.EQ.0. .AND.
     1    (MBDCND.EQ.3 .OR. MBDCND.EQ.4 .OR. MBDCND.EQ.8)) IERROR = 12
      IF (TF.EQ.PI .AND.
     1    (MBDCND.EQ.2 .OR. MBDCND.EQ.3 .OR. MBDCND.EQ.6)) IERROR = 13
      IF ((MBDCND.EQ.5 .OR. MBDCND.EQ.6 .OR. MBDCND.EQ.9) .AND.
     1    TS.NE.0.) IERROR = 14
      IF (MBDCND.GE.7 .AND. TF.NE.PI) IERROR = 15
      IF (IERROR.NE.0 .AND. IERROR.NE.9) RETURN
      CALL HWSSS1 (TS,TF,M,MBDCND,BDTS,BDTF,PS,PF,N,NBDCND,BDPS,BDPF,
     1             ELMBDA,F,IDIMF,PERTRB,W,W(M+2),W(2*M+3),W(3*M+4),
     2             W(4*M+5),W(5*M+6),W(6*M+7))
      W(1) = W(6*M+7)+FLOAT(6*(M+1))
      RETURN
      END
      SUBROUTINE HWSSS1 (TS,TF,M,MBDCND,BDTS,BDTF,PS,PF,N,NBDCND,BDPS,
     1                   BDPF,ELMBDA,F,IDIMF,PERTRB,AM,BM,CM,SN,SS,
     2                   SINT,D)
      DIMENSION       F(IDIMF,*) ,BDTS(*)    ,BDTF(*)    ,BDPS(*)    ,
     1                BDPF(*)    ,AM(*)      ,BM(*)      ,CM(*)      ,
     2                SS(*)      ,SN(*)      ,D(*)       ,SINT(*)
C
      PI = PIMACH(DUM)
      TPI = PI+PI
      HPI = PI/2.
      MP1 = M+1
      NP1 = N+1
      FN = N
      FM = M
      DTH = (TF-TS)/FM
      HDTH = DTH/2.
      TDT = DTH+DTH
      DPHI = (PF-PS)/FN
      TDP = DPHI+DPHI
      DPHI2 = DPHI*DPHI
      EDP2 = ELMBDA*DPHI2
      DTH2 = DTH*DTH
      CP = 4./(FN*DTH2)
      WP = FN*SIN(HDTH)/4.
      DO 102 I=1,MP1
         FIM1 = I-1
         THETA = FIM1*DTH+TS
         SINT(I) = SIN(THETA)
         IF (SINT(I)) 101,102,101
  101    T1 = 1./(DTH2*SINT(I))
         AM(I) = T1*SIN(THETA-HDTH)
         CM(I) = T1*SIN(THETA+HDTH)
         BM(I) = -AM(I)-CM(I)+ELMBDA
  102 CONTINUE
      INP = 0
      ISP = 0
C
C BOUNDARY CONDITION AT THETA=TS
C
      MBR = MBDCND+1
      GO TO (103,104,104,105,105,106,106,104,105,106),MBR
  103 ITS = 1
      GO TO 107
  104 AT = AM(2)
      ITS = 2
      GO TO 107
  105 AT = AM(1)
      ITS = 1
      CM(1) = AM(1)+CM(1)
      GO TO 107
  106 AT = AM(2)
      INP = 1
      ITS = 2
C
C BOUNDARY CONDITION THETA=TF
C
  107 GO TO (108,109,110,110,109,109,110,111,111,111),MBR
  108 ITF = M
      GO TO 112
  109 CT = CM(M)
      ITF = M
      GO TO 112
  110 CT = CM(M+1)
      AM(M+1) = AM(M+1)+CM(M+1)
      ITF = M+1
      GO TO 112
  111 ITF = M
      ISP = 1
      CT = CM(M)
C
C COMPUTE HOMOGENEOUS SOLUTION WITH SOLUTION AT POLE EQUAL TO ONE
C
  112 ITSP = ITS+1
      ITFM = ITF-1
      WTS = SINT(ITS+1)*AM(ITS+1)/CM(ITS)
      WTF = SINT(ITF-1)*CM(ITF-1)/AM(ITF)
      MUNK = ITF-ITS+1
      IF (ISP) 116,116,113
  113 D(ITS) = CM(ITS)/BM(ITS)
      DO 114 I=ITSP,M
         D(I) = CM(I)/(BM(I)-AM(I)*D(I-1))
  114 CONTINUE
      SS(M) = -D(M)
      IID = M-ITS
      DO 115 II=1,IID
         I = M-II
         SS(I) = -D(I)*SS(I+1)
  115 CONTINUE
      SS(M+1) = 1.
  116 IF (INP) 120,120,117
  117 SN(1) = 1.
      D(ITF) = AM(ITF)/BM(ITF)
      IID = ITF-2
      DO 118 II=1,IID
         I = ITF-II
         D(I) = AM(I)/(BM(I)-CM(I)*D(I+1))
  118 CONTINUE
      SN(2) = -D(2)
      DO 119 I=3,ITF
         SN(I) = -D(I)*SN(I-1)
  119 CONTINUE
C
C BOUNDARY CONDITIONS AT PHI=PS
C
  120 NBR = NBDCND+1
      WPS = 1.
      WPF = 1.
      GO TO (121,122,122,123,123),NBR
  121 JPS = 1
      GO TO 124
  122 JPS = 2
      GO TO 124
  123 JPS = 1
      WPS = .5
C
C BOUNDARY CONDITION AT PHI=PF
C
  124 GO TO (125,126,127,127,126),NBR
  125 JPF = N
      GO TO 128
  126 JPF = N
      GO TO 128
  127 WPF = .5
      JPF = N+1
  128 JPSP = JPS+1
      JPFM = JPF-1
      NUNK = JPF-JPS+1
      FJJ = JPFM-JPSP+1
C
C SCALE COEFFICIENTS FOR SUBROUTINE GENBUN
C
      DO 129 I=ITS,ITF
         CF = DPHI2*SINT(I)*SINT(I)
         AM(I) = CF*AM(I)
         BM(I) = CF*BM(I)
         CM(I) = CF*CM(I)
  129 CONTINUE
      AM(ITS) = 0.
      CM(ITF) = 0.
      ISING = 0
      GO TO (130,138,138,130,138,138,130,138,130,130),MBR
  130 GO TO (131,138,138,131,138),NBR
  131 IF (ELMBDA) 138,132,132
  132 ISING = 1
      SUM = WTS*WPS+WTS*WPF+WTF*WPS+WTF*WPF
      IF (INP) 134,134,133
  133 SUM = SUM+WP
  134 IF (ISP) 136,136,135
  135 SUM = SUM+WP
  136 SUM1 = 0.
      DO 137 I=ITSP,ITFM
         SUM1 = SUM1+SINT(I)
  137 CONTINUE
      SUM = SUM+FJJ*(SUM1+WTS+WTF)
      SUM = SUM+(WPS+WPF)*SUM1
      HNE = SUM
  138 GO TO (146,142,142,144,144,139,139,142,144,139),MBR
  139 IF (NBDCND-3) 146,140,146
  140 YHLD = F(1,JPS)-4./(FN*DPHI*DTH2)*(BDPF(2)-BDPS(2))
      DO 141 J=1,NP1
         F(1,J) = YHLD
  141 CONTINUE
      GO TO 146
  142 DO 143 J=JPS,JPF
         F(2,J) = F(2,J)-AT*F(1,J)
  143 CONTINUE
      GO TO 146
  144 DO 145 J=JPS,JPF
         F(1,J) = F(1,J)+TDT*BDTS(J)*AT
  145 CONTINUE
  146 GO TO (154,150,152,152,150,150,152,147,147,147),MBR
  147 IF (NBDCND-3) 154,148,154
  148 YHLD = F(M+1,JPS)-4./(FN*DPHI*DTH2)*(BDPF(M)-BDPS(M))
      DO 149 J=1,NP1
         F(M+1,J) = YHLD
  149 CONTINUE
      GO TO 154
  150 DO 151 J=JPS,JPF
         F(M,J) = F(M,J)-CT*F(M+1,J)
  151 CONTINUE
      GO TO 154
  152 DO 153 J=JPS,JPF
         F(M+1,J) = F(M+1,J)-TDT*BDTF(J)*CT
  153 CONTINUE
  154 GO TO (159,155,155,157,157),NBR
  155 DO 156 I=ITS,ITF
         F(I,2) = F(I,2)-F(I,1)/(DPHI2*SINT(I)*SINT(I))
  156 CONTINUE
      GO TO 159
  157 DO 158 I=ITS,ITF
         F(I,1) = F(I,1)+TDP*BDPS(I)/(DPHI2*SINT(I)*SINT(I))
  158 CONTINUE
  159 GO TO (164,160,162,162,160),NBR
  160 DO 161 I=ITS,ITF
         F(I,N) = F(I,N)-F(I,N+1)/(DPHI2*SINT(I)*SINT(I))
  161 CONTINUE
      GO TO 164
  162 DO 163 I=ITS,ITF
         F(I,N+1) = F(I,N+1)-TDP*BDPF(I)/(DPHI2*SINT(I)*SINT(I))
  163 CONTINUE
  164 CONTINUE
      PERTRB = 0.
      IF (ISING) 165,176,165
  165 SUM = WTS*WPS*F(ITS,JPS)+WTS*WPF*F(ITS,JPF)+WTF*WPS*F(ITF,JPS)+
     1      WTF*WPF*F(ITF,JPF)
      IF (INP) 167,167,166
  166 SUM = SUM+WP*F(1,JPS)
  167 IF (ISP) 169,169,168
  168 SUM = SUM+WP*F(M+1,JPS)
  169 DO 171 I=ITSP,ITFM
         SUM1 = 0.
         DO 170 J=JPSP,JPFM
            SUM1 = SUM1+F(I,J)
  170    CONTINUE
         SUM = SUM+SINT(I)*SUM1
  171 CONTINUE
      SUM1 = 0.
      SUM2 = 0.
      DO 172 J=JPSP,JPFM
         SUM1 = SUM1+F(ITS,J)
         SUM2 = SUM2+F(ITF,J)
  172 CONTINUE
      SUM = SUM+WTS*SUM1+WTF*SUM2
      SUM1 = 0.
      SUM2 = 0.
      DO 173 I=ITSP,ITFM
         SUM1 = SUM1+SINT(I)*F(I,JPS)
         SUM2 = SUM2+SINT(I)*F(I,JPF)
  173 CONTINUE
      SUM = SUM+WPS*SUM1+WPF*SUM2
      PERTRB = SUM/HNE
      DO 175 J=1,NP1
         DO 174 I=1,MP1
            F(I,J) = F(I,J)-PERTRB
  174    CONTINUE
  175 CONTINUE
C
C SCALE RIGHT SIDE FOR SUBROUTINE GENBUN
C
  176 DO 178 I=ITS,ITF
         CF = DPHI2*SINT(I)*SINT(I)
         DO 177 J=JPS,JPF
            F(I,J) = CF*F(I,J)
  177    CONTINUE
  178 CONTINUE
      CALL GENBUN (NBDCND,NUNK,1,MUNK,AM(ITS),BM(ITS),CM(ITS),IDIMF,
     1             F(ITS,JPS),IERROR,D)
      IF (ISING) 186,186,179
  179 IF (INP) 183,183,180
  180 IF (ISP) 181,181,186
  181 DO 182 J=1,NP1
         F(1,J) = 0.
  182 CONTINUE
      GO TO 209
  183 IF (ISP) 186,186,184
  184 DO 185 J=1,NP1
         F(M+1,J) = 0.
  185 CONTINUE
      GO TO 209
  186 IF (INP) 193,193,187
  187 SUM = WPS*F(ITS,JPS)+WPF*F(ITS,JPF)
      DO 188 J=JPSP,JPFM
         SUM = SUM+F(ITS,J)
  188 CONTINUE
      DFN = CP*SUM
      DNN = CP*((WPS+WPF+FJJ)*(SN(2)-1.))+ELMBDA
      DSN = CP*(WPS+WPF+FJJ)*SN(M)
      IF (ISP) 189,189,194
  189 CNP = (F(1,1)-DFN)/DNN
      DO 191 I=ITS,ITF
         HLD = CNP*SN(I)
         DO 190 J=JPS,JPF
            F(I,J) = F(I,J)+HLD
  190    CONTINUE
  191 CONTINUE
      DO 192 J=1,NP1
         F(1,J) = CNP
  192 CONTINUE
      GO TO 209
  193 IF (ISP) 209,209,194
  194 SUM = WPS*F(ITF,JPS)+WPF*F(ITF,JPF)
      DO 195 J=JPSP,JPFM
         SUM = SUM+F(ITF,J)
  195 CONTINUE
      DFS = CP*SUM
      DSS = CP*((WPS+WPF+FJJ)*(SS(M)-1.))+ELMBDA
      DNS = CP*(WPS+WPF+FJJ)*SS(2)
      IF (INP) 196,196,200
  196 CSP = (F(M+1,1)-DFS)/DSS
      DO 198 I=ITS,ITF
         HLD = CSP*SS(I)
         DO 197 J=JPS,JPF
            F(I,J) = F(I,J)+HLD
  197    CONTINUE
  198 CONTINUE
      DO 199 J=1,NP1
         F(M+1,J) = CSP
  199 CONTINUE
      GO TO 209
  200 RTN = F(1,1)-DFN
      RTS = F(M+1,1)-DFS
      IF (ISING) 202,202,201
  201 CSP = 0.
      CNP = RTN/DNN
      GO TO 205
  202 IF (ABS(DNN)-ABS(DSN)) 204,204,203
  203 DEN = DSS-DNS*DSN/DNN
      RTS = RTS-RTN*DSN/DNN
      CSP = RTS/DEN
      CNP = (RTN-CSP*DNS)/DNN
      GO TO 205
  204 DEN = DNS-DSS*DNN/DSN
      RTN = RTN-RTS*DNN/DSN
      CSP = RTN/DEN
      CNP = (RTS-DSS*CSP)/DSN
  205 DO 207 I=ITS,ITF
         HLD = CNP*SN(I)+CSP*SS(I)
         DO 206 J=JPS,JPF
            F(I,J) = F(I,J)+HLD
  206    CONTINUE
  207 CONTINUE
      DO 208 J=1,NP1
         F(1,J) = CNP
         F(M+1,J) = CSP
  208 CONTINUE
  209 IF (NBDCND) 212,210,212
  210 DO 211 I=1,MP1
         F(I,JPF+1) = F(I,JPS)
  211 CONTINUE
  212 RETURN
C
C REVISION HISTORY---
C
C SEPTEMBER 1973    VERSION 1
C APRIL     1976    VERSION 2
C JANUARY   1978    VERSION 3
C DECEMBER  1979    VERSION 3.1
C FEBRUARY  1985    DOCUMENTATION UPGRADE
C NOVEMBER  1988    VERSION 3.2, FORTRAN 77 CHANGES
C-----------------------------------------------------------------------
      END


PROGRAM num_table
IMPLICIT NONE
INTEGER :: index

WRITE(*, '(1X,A,1X,A9,2A6)') "N", "SQRT(N)", "N**2", "N**3"
WRITE(*, '(1X,A,2X,A,2(2X,A))') "--","-------","----","----"
DO index = 1, 10
  WRITE(*,'(I3,F9.5,2I6)') index, SQRT(REAL(index)), index**2, index**3
END DO

END PROGRAM num_table


subroutine init_phi(lo, hi, phi, philo, phihi, dx, prob_lo, prob_hi) bind(C, name="init_phi")
  !  Initialize the scalar field phi
  use amrex_fort_module, only : amrex_real

  implicit none

  integer, intent(in) :: lo(2), hi(2), philo(2), phihi(2)
  real(amrex_real), intent(inout) :: phi(philo(1):phihi(1),philo(2):phihi(2))
  real(amrex_real), intent(in   ) :: dx(2)
  real(amrex_real), intent(in   ) :: prob_lo(2)
  real(amrex_real), intent(in   ) :: prob_hi(2)

  integer          :: i,j
  double precision :: x,y,tupi
  tupi=3.14159265358979323846d0*2d0

  do j = lo(2), hi(2)
     y = prob_lo(2) + (dble(j)+0.5d0) * dx(2)
     do i = lo(1), hi(1)
        x = prob_lo(1) + (dble(i)) * dx(1)

        phi(i,j) =sin(x*tupi)*sin(y*tupi)
     end do
  end do

end subroutine init_phi

subroutine err_phi(lo, hi, phi, philo, phihi, dx, prob_lo, prob_hi,a,d,r,time) bind(C, name="err_phi")
  !  Subtract the exact solution from phi.  This will only work for special initial conditions
  !  We use the exact discretized form for diffusion and reaction, and exact translation for advection
  use amrex_fort_module, only : amrex_real

  implicit none

  integer, intent(in) :: lo(2), hi(2), philo(2), phihi(2)
  real(amrex_real), intent(inout) :: phi(philo(1):phihi(1),philo(2):phihi(2))
  real(amrex_real), intent(in   ) :: dx(2)
  real(amrex_real), intent(in   ) :: prob_lo(2)
  real(amrex_real), intent(in   ) :: prob_hi(2)
  real(amrex_real), intent(in   ) :: a,d,r
  real(amrex_real), intent(in   ) :: time

  integer          :: i,j
  double precision :: x,y,sym,tupi, maxphi

  tupi=3.14159265358979323846d0*2d0

  !  Form the diffusion coefficient for the 2nd order Laplacian produces
  sym=d*(-2.0d0+2.0d0*cos(tupi*dx(1)))/(dx(1)*dx(1))
  sym=sym+d*(-2.0d0+2.0d0*cos(tupi*dx(2)))/(dx(2)*dx(2))
  sym=sym-r    !  Add reaction

  maxphi=-1.0
  do j = lo(2), hi(2)
     y = prob_lo(2) + (dble(j)+0.5d0) * dx(2) +a*time
     do i = lo(1), hi(1)
        x = prob_lo(1) + (dble(i)) * dx(1) + a*time
        phi(i,j) = phi(i,j)-sin(x*tupi)*sin(y*tupi)*exp(time*sym)
        if (abs(phi(i,j)) .gt. maxphi) maxphi=abs(phi(i,j))
     end do
  end do

  print *,'max error in phi=',maxphi
end subroutine err_phi


Module vars
  integer, parameter :: imax=201, jmax=121
  integer, parameter :: kres=10, kqout=100
  integer :: kmax,irs,ire,jrs,jre
  real, parameter :: xl=10., yl=6., ck = 0.02, rl2allow=-5.
  real, dimension(imax,jmax) :: q_k,q_kp1, qx=0., qy=0.
  real :: dx,dy,beta2,dx2i,dy2i, x(imax),y(jmax), omega
  integer :: boundary,method
End module

!------------------------------------------------------------------------------|
!..A POINT ITERATIVE SOLVER FOR ELLIPTIC PDEs                                  |
!  Course:  AE305                                                              |
!------------------------------------------------------------------------------|
 program ELLIPTIC
 use vars
!..Read the input data, generate the grid data and initialize the solution
  call INIT()
!..Start the iterative solution loop
  k = 1
  DO WHILE (k .lt. kmax .and. rl2 .gt. rl2allow )
     k = k+1
!..Apply BCs
     call BC()
!..Point iterative solutions
     call POINT_ITERATE()
!..Evaluate the L2 norm of the residual and update q_k
     rl2 = SQRT(SUM((q_kp1-q_k)**2))
     if(k .eq. 2) rl2_1=rl2
     rl2 = ALOG10(rl2/rl2_1)
     if( MOD(k,kres).eq.0 .or. k .eq. 2) then
       print*, 'Residual @ k =',k,rl2
       write(2,*) k, rl2
     endif
     q_k = q_kp1
!..Output intermediate solutions
     if( MOD(k,kqout) .eq. 0 .and. k .ne. kmax) call QOUT(k)
  ENDDO
  print*, 'Residual @ k =',k,rl2
  write(2,*) k, rl2
  close(2)
  call QOUT(k)

  open(3,file='x5line.dat',form='formatted')
  ixline = 5 / dx + 1
  do j = 1,jmax
    write(3,*) j * dy  ,q_k(ixline,j)
  enddo
  close(3)

  open(4,file='y3line.dat',form='formatted')
  iyline = 3 / dy + 1
  do i = 1,imax
    write(4,*) i * dx  ,q_k(i,iyline)
  enddo
  close(4)

 stop
end

!------------------------------------------------------------------------
subroutine INIT()
 use vars

 write(*,'(a)') 'Select'
 write(*,'(a)') ' [1] Without Radiator'
 write(*,'(a)') ' [2] With Radiator'
 write(*,'(a)',advance='no')'>> '
 read(*,*) boundary

if(.not.(boundary.eq. 1 .or. boundary.eq.2)) then
  write(*,'(a)') 'Invalid Selection'
  stop
endif

if(boundary .eq. 2) then
  write(*,'(a)') 'Set radiator position'
  write(*,'(a)') 'Enter irs, ire, jrs, jre'
  write(*,'(a)') '(0 < irs,ire < 10) , (0 < jrs,jre < 6)'
  read(*,*) airs,aire,ajrs,ajre
endif

write(*,'(a)') 'Select'
write(*,'(a)') ' [1] Point Jacobi'
write(*,'(a)') ' [2] Gauss-Seidel'
write(*,'(a)') ' [3] SOR'
write(*,'(a)',advance='no')'>> '
read(*,*) method

if(.not.(method.eq. 1 .or. method.eq.2 .or. method.eq.3)) then
  write(*,'(a)') 'Invalid Selection'
  stop
endif

if(method .eq. 3) then
  write(*,'(a)') 'Enter omega (0 < omega < 2)'
  read(*,*) omega
endif

  write(*,'(a)',advance='no') 'Enter kmax: '
  read(*,*) kmax

  dx = xl/(imax-1)
  dy = yl/(jmax-1)

  print*, "Deltax: ",dx
  print*, "Deltay: ",dy
  beta2 = (dx/dy)**2

!..Grid generation
  do i=1,imax
     x(i)= dx*(i-1)
  enddo
  do j=1,jmax
     y(j)= dy*(j-1)
  enddo
  q_k = 0.       !..Initial guess

!..Set radiator location
  if(boundary.eq.2) then
  irs = airs/dx + 1
  ire = aire/dx + 1
  jrs = ajrs/dy + 1
  jre = ajre/dy + 1
  endif

 open(2,file='residual.dat',form='formatted')
 return
end

!-------------------------------------------------------------------
subroutine POINT_ITERATE()
 use vars

  cm = 1.0/(2.0*(1. + beta2))
  do j = 2,jmax-1
  do i = 2,imax-1
!..Exclude the radiator from the solution domain
     if(boundary.eq.2) then
     if (((j.ge.jrs).and.(j.le.jre)) .and. ((i.ge.irs).and.(i.le.ire))) then
       cycle
     endif
   endif
!..Implement, Point Jacobi, Gauss-Seidel and SOR methods
    if(method .eq. 1) then ! Point Jacobi
   q_kp1(i,j) = cm*( q_k(i-1,j) + q_k(i+1,j) + beta2*(q_k(i,j-1) + q_k(i,j+1)) )
    elseif(method .eq. 2) then ! Gauss-Seidel
   q_kp1(i,j) = cm*( q_kp1(i-1,j) + q_k(i+1,j) + beta2*(q_kp1(i,j-1) + q_k(i,j+1)) )
    elseif(method.eq.3) then ! SOR
   q_kp1(i,j) = (1-omega)*q_k(i,j) + omega*cm*( q_kp1(i-1,j) + q_k(i+1,j) + beta2*(q_kp1(i,j-1) + q_k(i,j+1)) )
    endif
  enddo
  enddo
 return
end

!-------------------------------------------------------------------
subroutine BC()
 use vars
  !..Set the bottom/top farfield BC
  q_k(:,1)      = 20.
  q_k(:,jmax)   = 0.
  q_kp1(:,1)    = q_k(:,1)
  q_kp1(:,jmax) = q_k(:,jmax)

  !..Set left/right farfield BC
  q_k  (1,:)    = q_k(2,:)
  q_k  (imax,:) = 20.
  q_kp1(1,:)    = q_k(1,:)
  q_kp1(imax,:) = q_k(imax,:)

!..Set BCs for the radiator
  if(boundary .eq. 2) then
  q_k( irs:ire, jrs:jre )   = 50
  q_kp1( irs:ire, jrs:jre ) = 50
  endif
 return
end

!-------------------------------------------------------------------
subroutine FLUX()
  use vars
!..Compute the heat flux vectors
  do j = 2,jmax-1
  do i = 2,imax-1
    qx(i,j) = -ck*(q_k(i+1,j)-q_k(i,j))/dx
    qy(i,j) = -ck*(q_k(i,j+1)-q_k(i,j))/dy
  enddo
  enddo
 return
end

!-------------------------------------------------------------------
subroutine QOUT(k)
 use vars
   character fname*32,string*9,ext*6
   write(string,'(f9.6)') float(k)/1000000
   read(string,'(3x,a6)') ext
   fname = 'q-'//ext//'.tec'
   open(1,file=fname,form='formatted')
   call FLUX
   write(1,*) ' variables="x","y","T","Tx","Ty"'
   write(1,*) ' zone i=',imax, ', j=',jmax
   do j=1,jmax
   do i=1,imax
      write(1,*) x(i),y(j),q_k(i,j),qx(i,j),qy(i,j)
   enddo
   enddo
   close(1)
 return
end

!-------------------------------------------------------------------
subroutine THOMAS(is,ie, a,b,c,f)
  use vars, only : imax
  real, dimension(imax) ::  a,b,c,f,x
!
!  Solution of a tridiagonal system of n equations of the form
!  A(i)*x(i-1) + B(i)*x(i) + C(i)*x(i+1) = F(i)  for k=is,ie
!  the solution X(i) is stored in F(i)
!  A(is-1) and C(ie+1) are not used.
!  Solution is returned in array F
!
   x(is)=c(is)/b(is)
   f(is)=f(is)/b(is)
   isp1 = is+1
   do i=isp1,ie
      z   =1./(b(i)-a(i)*x(i-1))
      x(i)=z*c(i)
      f(i)=(f(i)-a(i)*f(i-1))*z
   enddo
   iepis=ie+is
   do ii=isp1,ie
      i=iepis-ii
      f(i)=f(i)-x(i)*f(i+1)
   enddo

 return
end

!-------------------------------------------------------------------
subroutine GAUSS(n,a,b)
   real a(n,n),b(n)
!..Convert to upper triangular form
   do k = 1,N-1
   if (ABS(a(k,k)).gt.1.E-6) THEN
      do i = k+1, n
      x = a(i,k)/a(k,k)
         do j = k+1, n
            a(i,j) = a(i,j) -a(k,j)*x
         enddo
      b(i) = b(i) - b(k)*x
      enddo
   else
      write (6,*) 'zero pivot found in line:', k
      stop
   endif
   enddo
!..Back substitution
   do i = n,1,-1
     sum = b(i)
     if (i.lt.n) then
       do j= i+1,n
         sum = sum - a(i,j)*b(j)
       enddo
     endif
     b(i) = sum/a(i,i)
   enddo
  return
end


module constants
    ! Description:
    ! Definition of all constants for pamtra
    !
    ! History:
    ! Version   Date     Comment
    ! -------   ----     -------
    !  0.1   17/11/2009    creation of file

    use kinds, only: dbl

    implicit none
    save

    real(kind=dbl), parameter :: c = 299792458_dbl
    real(kind=dbl), parameter :: pi = 3.141592653589793_dbl
    real(kind=dbl), parameter :: t_abs = 273.15_dbl
    real(kind=dbl), parameter :: g = 9.80665_dbl
    real(kind=dbl), parameter :: sky_temp = 2.73_dbl
    real(kind=dbl), parameter :: rho_water = 1000_dbl
    real(kind=dbl), parameter :: rho_ice = 917._dbl   ! used to be 916.7_dbl (changed by MM 16.6.2016, due to check in make_soft_spheroid)

    real(kind=dbl), parameter :: tpt = 273.16_dbl               ! triple point temperature
    real(kind=dbl), parameter :: estpt = 611.14_dbl             ! saturation vapor triple point temperature
    real(kind=dbl), parameter :: mmd = 28.9644d-3               ! molar mass of dry air
    real(kind=dbl), parameter :: mmv = 18.0153d-3               ! molar mass of vapor
    real(kind=dbl), parameter :: k_b = 1.380658d-23             ! Boltzman constant
    real(kind=dbl), parameter :: n_a = 6.0221367d+23            ! Avogadro number
    real(kind=dbl), parameter :: r_d = 287.0596736665907_dbl    ! gas constant of dry air
    real(kind=dbl), parameter :: r_v = 461.5249933083879_dbl    ! gas constant of water vapor
    real(kind=dbl), parameter :: vapor_hc  = 2.5008d+6          ! vaporization heat constant
    real(kind=dbl), parameter :: sublim_hc  = 2.8345d+6         ! sublimation heat constant

    real(kind=dbl), parameter, public :: mu0 = pi * 4.0e-07_dbl           ! permeability of vacuum [N/A^2]
    real(kind=dbl), parameter, public :: eps0 = 1._dbl/(mu0*c**2) ! Permittivity of vacuum [F/m]

    real(kind=dbl), parameter :: delta_d_mono  = 1.d-8          ! delta diameter used for monodisperse drop-size distribution

    real(kind=dbl), parameter :: deg2rad = pi/180.0_dbl
    real(kind=dbl), parameter :: rad2deg = 180.0_dbl/pi
    complex(kind=dbl), parameter :: im = (0.0_dbl, 1.0_dbl)
    real(kind=dbl), parameter :: almostZero = 1d-20              !to account for numeric noise when comparing to zero

end module constants


*DECK DLSSUD
      SUBROUTINE DLSSUD (A, X, B, N, M, NRDA, U, NRDU, IFLAG, MLSO,
     +   IRANK, ISCALE, Q, DIAG, KPIVOT, S, DIV, TD, ISFLG, SCALES)
C***BEGIN PROLOGUE  DLSSUD
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DBVSUP and DSUDS
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (LSSUDS-S, DLSSUD-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C    DLSSUD solves the underdetermined system of equations  A Z = B,
C    where A is N by M and N .LE. M.  In particular, if rank A equals
C    IRA, a vector X and a matrix U are determined such that X is the
C    UNIQUE solution of smallest length, satisfying A X = B, and the
C    columns of U form an orthonormal basis for the null space of A,
C    satisfying A U = 0 .  Then all solutions Z are given by
C              Z = X + C(1)*U(1) + ..... + C(M-IRA)*U(M-IRA)
C    where U(J) represents the J-th column of U and the C(J) are
C    arbitrary constants.
C    If the system of equations are not compatible, only the least
C    squares solution of minimal length is computed.
C
C *********************************************************************
C   INPUT
C *********************************************************************
C
C     A -- Contains the matrix of N equations in M unknowns, A remains
C          unchanged, must be dimensioned NRDA by M.
C     X -- Solution array of length at least M.
C     B -- Given constant vector of length N, B remains unchanged.
C     N -- Number of equations, N greater or equal to 1.
C     M -- Number of unknowns, M greater or equal to N.
C     NRDA -- Row dimension of A, NRDA greater or equal to N.
C     U -- Matrix used for solution, must be dimensioned NRDU by
C          (M - rank of A).
C          (storage for U may be ignored when only the minimal length
C           solution X is desired)
C     NRDU -- Row dimension of U, NRDU greater or equal to M.
C             (if only the minimal length solution is wanted,
C              NRDU=0 is acceptable)
C     IFLAG -- Status indicator
C           =0  for the first call (and for each new problem defined by
C               a new matrix A) when the matrix data is treated as exact
C           =-K for the first call (and for each new problem defined by
C               a new matrix A) when the matrix data is assumed to be
C               accurate to about K digits.
C           =1  for subsequent calls whenever the matrix A has already
C               been decomposed (problems with new vectors B but
C               same matrix A can be handled efficiently).
C     MLSO -- =0 if only the minimal length solution is wanted.
C             =1 if the complete solution is wanted, includes the
C                linear space defined by the matrix U.
C     IRANK -- Variable used for the rank of A, set by the code.
C     ISCALE -- Scaling indicator
C               =-1 if the matrix A is to be pre-scaled by
C               columns when appropriate.
C               If the scaling indicator is not equal to -1
C               no scaling will be attempted.
C            For most problems scaling will probably not be necessary.
C     Q -- Matrix used for the transformation, must be dimensioned
C            NRDA by M.
C     DIAG,KPIVOT,S, -- Arrays of length at least N used for internal
C      DIV,TD,SCALES    storage (except for SCALES which is M).
C     ISFLG -- Storage for an internal variable.
C
C *********************************************************************
C   OUTPUT
C *********************************************************************
C
C     IFLAG -- Status indicator
C            =1 if solution was obtained.
C            =2 if improper input is detected.
C            =3 if rank of matrix is less than N.
C               To continue, simply reset IFLAG=1 and call DLSSUD again.
C            =4 if the system of equations appears to be inconsistent.
C               However, the least squares solution of minimal length
C               was obtained.
C     X -- Minimal length least squares solution of A Z = B
C     IRANK -- Numerically determined rank of A, must not be altered
C              on succeeding calls with input values of IFLAG=1.
C     U -- Matrix whose M-IRANK columns are mutually orthogonal unit
C          vectors which span the null space of A. This is to be ignored
C          when MLSO was set to zero or IFLAG=4 on output.
C     Q -- Contains the strictly upper triangular part of the reduced
C           matrix and transformation information.
C     DIAG -- Contains the diagonal elements of the triangular reduced
C             matrix.
C     KPIVOT -- Contains the pivotal information.  The row interchanges
C               performed on the original matrix are recorded here.
C     S -- Contains the solution of the lower triangular system.
C     DIV,TD -- Contains transformation information for rank
C               deficient problems.
C     SCALES -- Contains the column scaling parameters.
C
C *********************************************************************
C
C***SEE ALSO  DBVSUP, DSUDS
C***REFERENCES  H. A. Watts, Solving linear least squares problems
C                 using SODS/SUDS/CODS, Sandia Report SAND77-0683,
C                 Sandia Laboratories, 1977.
C***ROUTINES CALLED  D1MACH, DDOT, DOHTRL, DORTHR, J4SAVE, XERMAX,
C                    XERMSG, XGETF, XSETF
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900328  Added TYPE section.  (WRB)
C   910408  Updated the AUTHOR and REFERENCES sections.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DLSSUD
      INTEGER J4SAVE
      DOUBLE PRECISION DDOT, D1MACH
      INTEGER I, IFLAG, IRANK, IRP, ISCALE, ISFLG, J, JR, K, KP,
     1     KPIVOT(*), L, M, MAXMES, MJ, MLSO, N, NFAT, NFATAL, NMIR,
     2     NRDA, NRDU, NU
      DOUBLE PRECISION A(NRDA,*), B(*), DIAG(*), DIV(*), GAM, GAMMA,
     1     Q(NRDA,*), RES, S(*), SCALES(*), SS, TD(*), U(NRDU,*), URO,
     2     X(*)
C
C     ******************************************************************
C
C          MACHINE PRECISION (COMPUTER UNIT ROUNDOFF VALUE) IS DEFINED
C          BY THE FUNCTION D1MACH.
C
C     ******************************************************************
C
C     BEGIN BLOCK PERMITTING ...EXITS TO 310
C        BEGIN BLOCK PERMITTING ...EXITS TO 80
C***FIRST EXECUTABLE STATEMENT  DLSSUD
            URO = D1MACH(4)
C
            IF (N .LT. 1 .OR. M .LT. N .OR. NRDA .LT. N) GO TO 70
            IF (NRDU .NE. 0 .AND. NRDU .LT. M) GO TO 70
               IF (IFLAG .GT. 0) GO TO 60
C
                  CALL XGETF(NFATAL)
                  MAXMES = J4SAVE(4,0,.FALSE.)
                  ISFLG = -15
                  IF (IFLAG .EQ. 0) GO TO 10
                     ISFLG = IFLAG
                     NFAT = -1
                     IF (NFATAL .EQ. 0) NFAT = 0
                     CALL XSETF(NFAT)
                     CALL XERMAX(1)
   10             CONTINUE
C
C                 COPY MATRIX A INTO MATRIX Q
C
                  DO 30 K = 1, M
                     DO 20 J = 1, N
                        Q(J,K) = A(J,K)
   20                CONTINUE
   30             CONTINUE
C
C                 USE ORTHOGONAL TRANSFORMATIONS TO REDUCE Q TO LOWER
C                 TRIANGULAR FORM
C
                  CALL DORTHR(Q,N,M,NRDA,IFLAG,IRANK,ISCALE,DIAG,KPIVOT,
     1                        SCALES,DIV,TD)
C
                  CALL XSETF(NFATAL)
                  CALL XERMAX(MAXMES)
                  IF (IRANK .EQ. N) GO TO 40
C
C                    FOR RANK DEFICIENT PROBLEMS USE ADDITIONAL
C                    ORTHOGONAL TRANSFORMATIONS TO FURTHER REDUCE Q
C
                     IF (IRANK .NE. 0)
     1                  CALL DOHTRL(Q,N,NRDA,DIAG,IRANK,DIV,TD)
C     ...............EXIT
                     GO TO 310
   40             CONTINUE
C
C                 STORE DIVISORS FOR THE TRIANGULAR SOLUTION
C
                  DO 50 K = 1, N
                     DIV(K) = DIAG(K)
   50             CONTINUE
C        .........EXIT
                  GO TO 80
   60          CONTINUE
C        ......EXIT
               IF (IFLAG .EQ. 1) GO TO 80
   70       CONTINUE
C
C           INVALID INPUT FOR DLSSUD
            IFLAG = 2
            CALL XERMSG ('SLATEC', 'DLSSUD',
     +         'INVALID IMPUT PARAMETERS.', 2, 1)
C     ......EXIT
            GO TO 310
   80    CONTINUE
C
C
         IF (IRANK .GT. 0) GO TO 130
C
C           SPECIAL CASE FOR THE NULL MATRIX
            DO 110 K = 1, M
               X(K) = 0.0D0
               IF (MLSO .EQ. 0) GO TO 100
                  U(K,K) = 1.0D0
                  DO 90 J = 1, M
                     IF (J .NE. K) U(J,K) = 0.0D0
   90             CONTINUE
  100          CONTINUE
  110       CONTINUE
            DO 120 K = 1, N
               IF (B(K) .GT. 0.0D0) IFLAG = 4
  120       CONTINUE
         GO TO 300
  130    CONTINUE
C           BEGIN BLOCK PERMITTING ...EXITS TO 180
C
C              COPY CONSTANT VECTOR INTO S AFTER FIRST INTERCHANGING
C              THE ELEMENTS ACCORDING TO THE PIVOTAL SEQUENCE
C
               DO 140 K = 1, N
                  KP = KPIVOT(K)
                  X(K) = B(KP)
  140          CONTINUE
               DO 150 K = 1, N
                  S(K) = X(K)
  150          CONTINUE
C
               IRP = IRANK + 1
               NU = 1
               IF (MLSO .EQ. 0) NU = 0
C           ...EXIT
               IF (IRANK .EQ. N) GO TO 180
C
C              FOR RANK DEFICIENT PROBLEMS WE MUST APPLY THE
C              ORTHOGONAL TRANSFORMATION TO S
C              WE ALSO CHECK TO SEE IF THE SYSTEM APPEARS TO BE
C              INCONSISTENT
C
               NMIR = N - IRANK
               SS = DDOT(N,S(1),1,S(1),1)
               DO 170 L = 1, IRANK
                  K = IRP - L
                  GAM = ((TD(K)*S(K)) + DDOT(NMIR,Q(IRP,K),1,S(IRP),1))
     1                  /(TD(K)*DIV(K))
                  S(K) = S(K) + GAM*TD(K)
                  DO 160 J = IRP, N
                     S(J) = S(J) + GAM*Q(J,K)
  160             CONTINUE
  170          CONTINUE
               RES = DDOT(NMIR,S(IRP),1,S(IRP),1)
C           ...EXIT
               IF (RES
     1             .LE. SS*(10.0D0*MAX(10.0D0**ISFLG,10.0D0*URO))**2)
     2            GO TO 180
C
C              INCONSISTENT SYSTEM
               IFLAG = 4
               NU = 0
  180       CONTINUE
C
C           APPLY FORWARD SUBSTITUTION TO SOLVE LOWER TRIANGULAR SYSTEM
C
            S(1) = S(1)/DIV(1)
            IF (IRANK .LT. 2) GO TO 200
            DO 190 K = 2, IRANK
               S(K) = (S(K) - DDOT(K-1,Q(K,1),NRDA,S(1),1))/DIV(K)
  190       CONTINUE
  200       CONTINUE
C
C           INITIALIZE X VECTOR AND THEN APPLY ORTHOGONAL TRANSFORMATION
C
            DO 210 K = 1, M
               X(K) = 0.0D0
               IF (K .LE. IRANK) X(K) = S(K)
  210       CONTINUE
C
            DO 230 JR = 1, IRANK
               J = IRP - JR
               MJ = M - J + 1
               GAMMA = DDOT(MJ,Q(J,J),NRDA,X(J),1)/(DIAG(J)*Q(J,J))
               DO 220 K = J, M
                  X(K) = X(K) + GAMMA*Q(J,K)
  220          CONTINUE
  230       CONTINUE
C
C           RESCALE ANSWERS AS DICTATED
C
            DO 240 K = 1, M
               X(K) = X(K)*SCALES(K)
  240       CONTINUE
C
            IF (NU .EQ. 0 .OR. M .EQ. IRANK) GO TO 290
C
C              INITIALIZE U MATRIX AND THEN APPLY ORTHOGONAL
C              TRANSFORMATION
C
               L = M - IRANK
               DO 280 K = 1, L
                  DO 250 I = 1, M
                     U(I,K) = 0.0D0
                     IF (I .EQ. IRANK + K) U(I,K) = 1.0D0
  250             CONTINUE
C
                  DO 270 JR = 1, IRANK
                     J = IRP - JR
                     MJ = M - J + 1
                     GAMMA = DDOT(MJ,Q(J,J),NRDA,U(J,K),1)
     1                       /(DIAG(J)*Q(J,J))
                     DO 260 I = J, M
                        U(I,K) = U(I,K) + GAMMA*Q(J,I)
  260                CONTINUE
  270             CONTINUE
  280          CONTINUE
  290       CONTINUE
  300    CONTINUE
  310 CONTINUE
C
      RETURN
      END


Subroutine Jacobi
use Aero2DCOM
implicit none
integer i,j,k,Imin
real(8) Xmin
real(8) theta(Ic,Jc),dw(Ib1:Ib2)
dx=1
dy=1
Xg=Xg*c
Yg=Yg*c
DO j=1,Jc
  DO i=1,Ic
   Xc(i,j)=(Xg(i,j)+Xg(i+1,j)+Xg(i,j+1)+Xg(i+1,j+1))/4
   Yc(i,j)=(Yg(i,j)+Yg(i+1,j)+Yg(i,j+1)+Yg(i+1,j+1))/4
   Xgk(i,j)=((Xg(i+1,j)+Xg(i+1,j+1))-(Xg(i,j)+Xg(i,j+1)))/(2*dx)
   Ygk(i,j)=((Yg(i+1,j)+Yg(i+1,j+1))-(Yg(i,j)+Yg(i,j+1)))/(2*dx)
   Xga(i,j)=((Xg(i,j+1)+Xg(i+1,j+1))-(Xg(i,j)+Xg(i+1,j)))/(2*dy)
   Yga(i,j)=((Yg(i,j+1)+Yg(i+1,j+1))-(Yg(i,j)+Yg(i+1,j)))/(2*dy)
  end DO
end DO
Jg=Xgk*Yga-Xga*Ygk
dk=sqrt(Xgk**2+Ygk**2)
da=sqrt(Xga**2+Yga**2)
a1=(Xga**2+Yga**2)/Jg
y1=(Xgk**2+Ygk**2)/Jg
b1=(Xgk*Xga+Ygk*Yga)/Jg
theta=180*acos(b1/sqrt(a1*y1))/Pi
Xmin=1e+30
Imin=(Ib1+Ib2+1)/2
DO i=Ib1,Ib2
 Xw(i)=0.5*(Xg(i+1,1)+Xg(i,1))
 Yw(i)=0.5*(Yg(i+1,1)+Yg(i,1))
 Yp(i)=sqrt((Xc(i,1)-Xw(i))**2+(Yc(i,1)-Yw(i))**2)
 DR(i)=sqrt((Xg(i+1,1)-Xg(i,1))**2+(Yg(i+1,1)-Yg(i,1))**2)
 if(Xg(i,1)<Xmin) then
  Xmin=Xg(i,1)
  Imin=i
 end if
end DO
Sw(Imin)=DR(Imin)/2
Sw(Imin-1)=-DR(Imin-1)/2
DO i=Imin+1,Ib2
 Sw(i)=Sw(i-1)+DR(i-1)/2+DR(i)/2
end DO
DO i=Imin-2,Ib1,-1
 Sw(i)=Sw(i+1)-DR(i+1)/2-DR(i)/2
end DO
DO j=1,Jc
 DO i=1,Ic
  DO k=Ib1,Ib2
   dw(k)=sqrt((Xc(i,j)-Xw(k))**2+(Yc(i,j)-Yw(k))**2)
  end DO
  d(i,j)=minval(dw)
 end DO
end DO
print *,'The minimum and maximum angle of grid cells are:'
print *,minval(theta),maxval(theta)
end Subroutine Jacobi


!> \file mo_interpol.f90

!> \brief Module for linear and cubic B spline interpolation

!> \details The module provides one routine for linear interpolation of irregular grids
!>          and one routine for interpolation with cubic B splines.

!> \authors Matthias Cuntz
!> \date 2011-2014
MODULE mo_interpol

  ! This module provides a linear interpolation routine for irregular grids
  ! and a routine for cubic B spline interpolation

  ! Literature
  !   Inspired by interpolation routines of Numerical Recipes
  !       WH Press, SA Teukolsky, WT Vetterling, BP Flannery,
  !           Numerical Recipes in Fortran 90 - The Art of Parallel Scientific Computing, 2nd Edition
  !           Volume 2 of Fortran Numerical Recipes, Cambridge University Press, UK, 1996
  !   and IDL routine interpol.pro Copyright (C) 1982-2004, Research Systems, Inc.
  !   The cubic B spline is a Fortran 90 version of the Fortran 77 version of John Burkardt.

  ! Written  Mar 2011, Matthias Cuntz - only linear interpolation
  ! Modified Jul 2013, Matthias Cuntz - added cubic B splines
  !          May 2014, Matthias Cuntz - removed numerical recipes

  ! License
  ! -------
  ! This file is part of the JAMS Fortran package, distributed under the MIT License.
  !
  ! Copyright (c) 2011-2014 Matthias Cuntz - mc (at) macu (dot) de
  !
  ! Permission is hereby granted, free of charge, to any person obtaining a copy
  ! of this software and associated documentation files (the "Software"), to deal
  ! in the Software without restriction, including without limitation the rights
  ! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  ! copies of the Software, and to permit persons to whom the Software is
  ! furnished to do so, subject to the following conditions:
  !
  ! The above copyright notice and this permission notice shall be included in all
  ! copies or substantial portions of the Software.
  !
  ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  ! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  ! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  ! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  ! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  ! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  ! SOFTWARE.

  USE mo_kind,  ONLY: i4, sp, dp
  USE mo_utils, only: locate

  Implicit NONE

  PUBLIC :: interpol        ! Linearly interpolate vectors with an irregular grid
  PUBLIC :: spline_b        ! Cubic B spline interpolation

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

  !     NAME
  !         interpol

  !     PURPOSE
  !>        \brief Linear interpolation on irregular grid.

  !>        \details Linearly interpolate vectors with an irregular grid.
  !>           yout = interpol(yin, xin, xout)
  !>           be z = xin(i) then
  !>           yout(i) = yin(i) + (z - floor(z)) * (yin(i+1) - yin(i))

  !     CALLING SEQUENCE
  !         yout = interpol(yin, xin, xout)

  !     INTENT(IN)
  !>        \param[in] "real(sp/dp) :: yin(:)"      1D-array with input values to interpolate
  !>        \param[in] "real(sp/dp) :: xin(:)"      1D-array with position of yin values
  !>        \param[in] "real(sp/dp) :: xout(:)"     1D-array with wanted positions of interpolated values

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         None

  !     INTENT(IN), OPTIONAL
  !         None

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RETURN
  !>       \return     real(sp/dp) :: yout — interpolated values at xout

  !     RESTRICTIONS
  !>       \note Index arrays are not working with all compilers. Compile with -DABSOFT if problems occur.

  !     EXAMPLE
  !         ! Fill masked values of vector w with interpolated values
  !         w = interpol(pack(w,wmaske), pack(date,wmaske), date)
  !         -> see also example in test directory

  !     LITERATURE
  !       WH Press, SA Teukolsky, WT Vetterling, BP Flannery,
  !           Numerical Recipes in Fortran 90 - The Art of Parallel Scientific Computing, 2nd Edition
  !           Volume 2 of Fortran Numerical Recipes, Cambridge University Press, UK, 1996
  !       IDL routine interpol.pro Copyright (C) 1982-2004, Research Systems, Inc.

  !     HISTORY
  !>        \author Written,  Matthias Cuntz
  !>        \date Nov 2011
  INTERFACE interpol
     MODULE PROCEDURE interpol_sp, interpol_dp
  END INTERFACE interpol

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

  !     NAME
  !         spline_b

  !     PURPOSE
  !>        \brief Evaluates a cubic B spline approximant.

  !>        \details The cubic B spline will approximate the data, but is not
  !>                 designed to interpolate it.
  !>
  !>                 In effect, two "phantom" data values are appended to the data,
  !>                 so that the spline will interpolate the first and last data values.

  !     CALLING SEQUENCE
  !         yout = spline_b(yin, xin, xout)

  !     INTENT(IN)
  !>        \param[in] "real(sp/dp) :: yin(:)"      1D-array with input values to interpolate
  !>        \param[in] "real(sp/dp) :: xin(:)"      1D-array with position of yin values
  !>        \param[in] "real(sp/dp) :: xout(:)"     1D-array with wanted positions of interpolated values

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         None

  !     INTENT(IN), OPTIONAL
  !         None

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RETURN
  !>       \return     real(sp/dp) :: yout — spline-interpolated values at xout

  !     RESTRICTIONS
  !         None

  !     EXAMPLE
  !         ! Fill masked values of vector w with interpolated values
  !         w = spline_b(pack(w,wmaske), pack(date,wmaske), date)
  !         -> see also example in test directory

  !     LITERATURE
  !         Carl deBoor, A Practical Guide to Splines, Springer, 2001, ISBN: 0387953663.

  !     HISTORY
  !>        \author Written, John Burkardt (F77, Feb 2004). Modified Matthias Cuntz (F90, Jul 2013)
  !>        \date 1999-2013
  INTERFACE spline_b
     MODULE PROCEDURE spline_b_dp, spline_b_sp
  END INTERFACE spline_b

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

  PRIVATE

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

  ! For splines
  INTERFACE bracket
     MODULE PROCEDURE bracket_dp, bracket_sp
  END INTERFACE bracket

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

CONTAINS

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

  ! BRACKET searches a sorted vector for successive brackets of a value.
  !
  !  Discussion:
  !    A vector is an array of double precision real values.
  !    If the values in the vector are thought of as defining intervals
  !    on the real line, then this routine searches for the interval
  !    nearest to or containing the given value.
  !
  !  Licensing:
  !    This code is distributed under the GNU LGPL license.
  !
  !  Parameters:
  !    Input, real(dp) X(N), an array sorted into ascending order.
  !    Input, real(dp) XVAL(M), values to be bracketed.
  !    Output, integer(i4) LEFT(M), RIGHT(M), the results of the search.
  !    Either:
  !      XVAL < X(1), when LEFT = 1, RIGHT = 2;
  !      X(N) < XVAL, when LEFT = N-1, RIGHT = N;
  !    or
  !      X(LEFT) <= XVAL <= X(RIGHT).

  !     HISTORY
  !        \author Written, John Burkardt (F77, Apr 1999). Modified Matthias Cuntz (F90, Jul 2013)
  !        \date 1999-2013
  subroutine bracket_dp(x, xval, left, right)

    implicit none

    real(dp), dimension(:), intent(in) :: x
    real(dp), dimension(:), intent(in) :: xval
    integer(i4), dimension(size(xval)), intent(out) :: left
    integer(i4), dimension(size(xval)), intent(out) :: right

    integer(i4) :: n, m
    integer(i4) :: i, j
    logical :: istheend

    n = size(x)
    m = size(xval)
    do j=1, m
       istheend = .true.
       do i = 2, n - 1
          if ( xval(j) < x(i) ) then
             left(j)  = i - 1
             right(j) = i
             istheend = .false.
             exit
          end if
       end do
       if (istheend) then
          left(j)  = n - 1
          right(j) = n
       endif
    end do

    return

  end subroutine bracket_dp

  subroutine bracket_sp(x, xval, left, right)

    implicit none

    real(sp), dimension(:), intent(in) :: x
    real(sp), dimension(:), intent(in) :: xval
    integer(i4), dimension(size(xval)), intent(out) :: left
    integer(i4), dimension(size(xval)), intent(out) :: right

    integer(i4) :: n, m
    integer(i4) :: i, j
    logical :: istheend

    n = size(x)
    m = size(xval)
    do j=1, m
       istheend = .true.
       do i = 2, n - 1
          if ( xval(j) < x(i) ) then
             left(j)  = i - 1
             right(j) = i
             istheend = .false.
             exit
          end if
       end do
       if (istheend) then
          left(j)  = n - 1
          right(j) = n
       endif
    end do

    return

  end subroutine bracket_sp

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

  FUNCTION interpol_dp(v, x, u)

    IMPLICIT NONE

    REAL(dp),    DIMENSION(:), INTENT(IN) :: v
    REAL(dp),    DIMENSION(:), INTENT(IN) :: x
    REAL(dp),    DIMENSION(:), INTENT(IN) :: u
    REAL(dp),    DIMENSION(size(u))       :: interpol_dp

    INTEGER(i4), DIMENSION(size(u)) :: s
#ifdef __ABSOFT__
    REAL(dp)                        :: ums
#else
    REAL(dp),    DIMENSION(size(u)) :: ums
#endif
    INTEGER(i4) :: m
#ifdef __ABSOFT__
    INTEGER(i4) :: n
    INTEGER(i4) :: i
#endif

    m = size(v)
    if (size(x) /= m) stop 'Error interpol_dp: size(v) /= size(x)'

    s = min(max(locate(x, u), 1_i4), m-1_i4)  ! Subscript intervals

#ifdef __ABSOFT__
    n = size(u)
    do i=1, n
       ums = u(i) - x(s(i))
       if (abs(ums) < epsilon(1.0_dp)) ums = 0.0_dp
       interpol_dp(i) = v(s(i)) + ums*(v(s(i)+1)-v(s(i)))/(x(s(i)+1)-x(s(i)))
    end do
#else
    ums = (u-x(s)) ! distance from point before
    where (abs(ums) < epsilon(1.0_dp)) ums = 0.0_dp ! for numerical stability
    interpol_dp = v(s) + ums*(v(s+1)-v(s))/(x(s+1)-x(s))
#endif

  END FUNCTION interpol_dp

  FUNCTION interpol_sp(v, x, u)

    IMPLICIT NONE

    REAL(sp),    DIMENSION(:), INTENT(IN) :: v
    REAL(sp),    DIMENSION(:), INTENT(IN) :: x
    REAL(sp),    DIMENSION(:), INTENT(IN) :: u
    REAL(sp),    DIMENSION(size(u))       :: interpol_sp

    INTEGER(i4), DIMENSION(size(u)) :: s
#ifdef __ABSOFT__
    REAL(sp)                        :: ums
#else
    REAL(sp),    DIMENSION(size(u)) :: ums
#endif
    INTEGER(i4) :: m
#ifdef __ABSOFT__
    INTEGER(i4) :: n
    INTEGER(i4) :: i
#endif

    m = size(v)
    if (size(x) /= m) stop 'Error interpol_sp: size(v) /= size(x)'

    s = min(max(locate(x, u), 1_i4), m-1_i4)  ! Subscript intervals

#ifdef __ABSOFT__
    n = size(u)
    do i=1, n
       ums = u(i) - x(s(i))
       if (abs(ums) < epsilon(1.0_sp)) ums = 0.0_sp
       interpol_sp(i) = v(s(i)) + ums*(v(s(i)+1)-v(s(i)))/(x(s(i)+1)-x(s(i)))
    end do
#else
    ums = (u-x(s)) ! distance from point before
    where (abs(ums) < epsilon(1.0_sp)) ums = 0.0_sp ! for numerical stability
    interpol_sp = v(s) + ums*(v(s+1)-v(s))/(x(s+1)-x(s))
#endif

  END FUNCTION interpol_sp

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

  !    The cubic B spline will approximate the data, but is not
  !    designed to interpolate it.
  !
  !    In effect, two "phantom" data values are appended to the data,
  !    so that the spline will interpolate the first and last data values.
  function spline_b_dp(ydata, tdata, tval)

    implicit none

    real(dp), dimension(:), intent(in) :: ydata
    real(dp), dimension(:), intent(in) :: tdata
    real(dp), dimension(:), intent(in) :: tval
    real(dp), dimension(size(tval))    :: spline_b_dp

    integer(i4) :: ndata
    real(dp),    dimension(size(tval)) :: bval
    integer(i4), dimension(size(tval)) :: left
    integer(i4), dimension(size(tval)) :: right
    real(dp),    dimension(size(tval)) :: u

    ndata = size(tdata)
    !
    !  Find the nearest interval [ TDATA(LEFT), TDATA(RIGHT) ] to TVAL.
    !
    call bracket(tdata, tval, left, right)
    !
    !  Evaluate the 5 nonzero B spline basis functions in the interval,
    !  weighted by their corresponding data values.
    !
    u = ( tval - tdata(left) ) / ( tdata(right) - tdata(left) )
    spline_b_dp = 0.0_dp
    !
    !  B function associated with node LEFT - 1, (or "phantom node"),
    !  evaluated in its 4th interval.
    !
    bval = ( ( (     - 1.0_dp   &
         * u + 3.0_dp ) &
         * u - 3.0_dp ) &
         * u + 1.0_dp ) / 6.0_dp

    where ( 0 < left-1 )
       spline_b_dp = spline_b_dp + ydata(left-1) * bval
    elsewhere
       spline_b_dp = spline_b_dp + ( 2.0_dp * ydata(1) - ydata(2) ) * bval
    end where
    !
    !  B function associated with node LEFT,
    !  evaluated in its third interval.
    !
    bval = ( ( (       3.0_dp   &
         * u - 6.0_dp ) &
         * u + 0.0_dp ) &
         * u + 4.0_dp ) / 6.0_dp

    spline_b_dp = spline_b_dp + ydata(left) * bval
    !
    !  B function associated with node RIGHT,
    !  evaluated in its second interval.
    !
    bval = ( ( (     - 3.0_dp   &
         * u + 3.0_dp ) &
         * u + 3.0_dp ) &
         * u + 1.0_dp ) / 6.0_dp

    spline_b_dp = spline_b_dp + ydata(right) * bval
    !
    !  B function associated with node RIGHT+1, (or "phantom node"),
    !  evaluated in its first interval.
    !
    bval = u**3 / 6.0_dp

    where ( right+1 <= ndata )
       spline_b_dp = spline_b_dp + ydata(right+1) * bval
    elsewhere
       spline_b_dp = spline_b_dp + ( 2.0_dp * ydata(ndata) - ydata(ndata-1) ) * bval
    end where

    return

  end function spline_b_dp

  function spline_b_sp(ydata, tdata, tval)

    implicit none

    real(sp), dimension(:), intent(in) :: ydata
    real(sp), dimension(:), intent(in) :: tdata
    real(sp), dimension(:), intent(in) :: tval
    real(sp), dimension(size(tval))    :: spline_b_sp

    integer(i4) :: ndata
    real(sp),    dimension(size(tval)) :: bval
    integer(i4), dimension(size(tval)) :: left
    integer(i4), dimension(size(tval)) :: right
    real(sp),    dimension(size(tval)) :: u

    ndata = size(tdata)
    !
    !  Find the nearest interval [ TDATA(LEFT), TDATA(RIGHT) ] to TVAL.
    !
    call bracket(tdata, tval, left, right)
    !
    !  Evaluate the 5 nonzero B spline basis functions in the interval,
    !  weighted by their corresponding data values.
    !
    u = ( tval - tdata(left) ) / ( tdata(right) - tdata(left) )
    spline_b_sp = 0.0_sp
    !
    !  B function associated with node LEFT - 1, (or "phantom node"),
    !  evaluated in its 4th interval.
    !
    bval = ( ( (     - 1.0_sp   &
         * u + 3.0_sp ) &
         * u - 3.0_sp ) &
         * u + 1.0_sp ) / 6.0_sp

    where ( 0 < left-1 )
       spline_b_sp = spline_b_sp + ydata(left-1) * bval
    elsewhere
       spline_b_sp = spline_b_sp + ( 2.0_sp * ydata(1) - ydata(2) ) * bval
    end where
    !
    !  B function associated with node LEFT,
    !  evaluated in its third interval.
    !
    bval = ( ( (       3.0_sp   &
         * u - 6.0_sp ) &
         * u + 0.0_sp ) &
         * u + 4.0_sp ) / 6.0_sp

    spline_b_sp = spline_b_sp + ydata(left) * bval
    !
    !  B function associated with node RIGHT,
    !  evaluated in its second interval.
    !
    bval = ( ( (     - 3.0_sp   &
         * u + 3.0_sp ) &
         * u + 3.0_sp ) &
         * u + 1.0_sp ) / 6.0_sp

    spline_b_sp = spline_b_sp + ydata(right) * bval
    !
    !  B function associated with node RIGHT+1, (or "phantom node"),
    !  evaluated in its first interval.
    !
    bval = u**3 / 6.0_sp

    where ( right+1 <= ndata )
       spline_b_sp = spline_b_sp + ydata(right+1) * bval
    elsewhere
       spline_b_sp = spline_b_sp + ( 2.0_sp * ydata(ndata) - ydata(ndata-1) ) * bval
    end where

    return

  end function spline_b_sp

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

END MODULE mo_interpol


program q2
  use utils
  implicit none

  call main()

contains

  subroutine main()
    !! Find extrema
    print *
    print "(a)", "2. Extrema of x^4 + 3x^3 - 4x^2 - 3x + 4"
    print "(f18.12)", golden(f2,   x_min=-4.0, x_max=-2.0, tol=1e-12)
    print "(f18.12)", golden(f2_n, x_min=-2.0, x_max= 0.0, tol=1e-12)
    print "(f18.12)", golden(f2,   x_min= 0.0, x_max= 2.0, tol=1e-12)

    print *
  end subroutine

  pure function f2(x)
    !! Function for question 2
    real, intent(in) :: x
    real :: f2

    f2 = x**4 + 3*x**3 - 4*x**2 - 3*x + 4
  end function

  pure function f2_n(x)
    !! Function for question 2, negated
    real, intent(in) :: x
    real :: f2_n

    f2_n = -f2(x)
  end function

end program q2


PROGRAM A8Q2
!--
! Determines if a graph represente by a Adjancy matrix A is strongly connected
! (if there exists a path from one node to any other node)
!--
IMPLICIT NONE
CHARACTER(80) :: Chars
INTEGER, DIMENSION(:, :), ALLOCATABLE :: A
INTEGER :: n, check, i, j, m
LOGICAL :: r

PRINT *, "Determines if a graph represente by a Adjancy matrix A is strongly connected"
PRINT *, "(if there exists a path from one node to any other node)"
DO
  	PRINT *, "Please enter the number of nodes, n (0 to stop)"
    READ *, n
    IF (n .eq. 0) STOP
    ALLOCATE(A(n,n), STAT=check)
    IF (check .ne. 0) THEN
      	PRINT *, "Allocation unsuccessful, please try again"
    ELSE
      	A = 0
		PRINT *, "Enter the graph, node after node:"
        DO i = 1, n
			READ "(A)", Chars
            READ (Chars,*) j
            m = INDEX(Chars, ':')
            DO WHILE (m .gt. 0)
				Chars(m:m) = ' '
                READ (Chars(m:),*) j
                IF (j .ne. 0) A(i,j) = 1
                m = INDEX(Chars, ',')
            END DO
        END DO
        PRINT *, "Adjancy matrix A:"
        DO i = 1,n
			PRINT "(5X, 15I5)", A(i, 1:n)
        END DO
        r = StronglyConn(A, n)
        IF (r) THEN
          	PRINT *, "This graph is strongly connected!"
        ELSE
          	PRINT *, "This graph is not strongly connected!"
        END IF
        DEALLOCATE(A)
    END IF
END DO

CONTAINS
LOGICAL FUNCTION StronglyConn(A, n)
INTEGER, DIMENSION(n, n), INTENT(IN) :: A
INTEGER, INTENT(IN) :: n
INTEGER, DIMENSION(n) :: C
INTEGER :: i, j

C = 0
!- Innocent until proven guilty!
StronglyConn = .true.
DO i = 1,n
	DO j = 1,n
    	!- We can't consider node loops, since that loop may be the only path to the node
        !- and therefore there is no path to that node from any other node.
    	IF (A(i,j) .eq. 1 .and. i .ne. j) THEN
			C(j) = 1
		END IF
	END DO
END DO
DO i = 1,n
	IF (C(i) .eq. 0) THEN
		PRINT "(1X, 'There is no path to node', I3)", i
        stronglyConn = .false.
    END IF
END DO

END FUNCTION StronglyConn
END PROGRAM A8Q2


C$Procedure      EUL2M ( Euler angles to matrix )

      SUBROUTINE EUL2M (  ANGLE3,   ANGLE2,   ANGLE1,
     .                    AXIS3,    AXIS2,    AXIS1,   R  )

C$ Abstract
C
C     Construct a rotation matrix from a set of Euler angles.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     ROTATION
C
C$ Keywords
C
C     MATRIX
C     ROTATION
C     TRANSFORMATION
C
C$ Declarations

      DOUBLE PRECISION      ANGLE3
      DOUBLE PRECISION      ANGLE2
      DOUBLE PRECISION      ANGLE1

      INTEGER               AXIS3
      INTEGER               AXIS2
      INTEGER               AXIS1

      DOUBLE PRECISION      R ( 3, 3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     ANGLE3,
C     ANGLE2,
C     ANGLE1     I   Rotation angles about third, second, and first
C                    rotation axes (radians).
C     AXIS3,
C     AXIS2,
C     AXIS1      I   Axis numbers of third, second, and first rotation
C                    axes.
C
C     R          O   Product of the 3 rotations.
C
C$ Detailed_Input
C
C     ANGLE3,
C     ANGLE2,
C     ANGLE1,
C
C     AXIS3,
C     AXIS2,
C     AXIS1          are, respectively, a set of three angles and three
C                    coordinate axis numbers; each pair ANGLEx and
C                    AXISx specifies a coordinate transformation
C                    consisting of a rotation by ANGLEx radians about
C                    the coordinate axis indexed by AXISx.  These
C                    coordinate transformations are typically
C                    symbolized by
C
C                       [ ANGLEx ]     .
C                                 AXISx
C
C                    See the $ Particulars section below for details
C                    concerning this notation.
C
C                    Note that these coordinate transformations rotate
C                    vectors by
C
C                       -ANGLEx
C
C                    radians about the axis indexed by AXISx.
C
C                    The values of AXISx may be 1, 2, or 3, indicating
C                    the x, y, and z axes respectively.
C
C$ Detailed_Output
C
C     R              is a rotation matrix representing the composition
C                    of the rotations defined by the input angle-axis
C                    pairs.  Together, the three pairs specify a
C                    composite transformation that is the result of
C                    performing the rotations about the axes indexed
C                    by AXIS1, AXIS2, and AXIS3, in that order.  So,
C
C                       R = [ ANGLE3 ]    [ ANGLE2 ]      [ ANGLE1 ]
C                                    AXIS3          AXIS2          AXIS1
C
C                    See the $ Particulars section below for details
C                    concerning this notation.
C
C                    The resulting matrix R may be thought of as a
C                    coordinate transformation; applying it to a vector
C                    yields the vector's coordinates in the rotated
C                    system.
C
C                    Viewing R as a coordinate transformation matrix,
C                    the basis that R transforms vectors to is created
C                    by rotating the original coordinate axes first by
C                    ANGLE1 radians about the coordinate axis indexed
C                    by AXIS1, next by ANGLE2 radians about the
C                    coordinate axis indexed by AXIS2, and finally by
C                    ANGLE3 radians about coordinate axis indexed by
C                    AXIS3.  At the second and third steps of this
C                    process, the coordinate axes about which rotations
C                    are performed belong to the bases resulting from
C                    the previous rotations.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)   If any of AXIS3, AXIS2, or AXIS1 do not have values in
C
C             { 1, 2, 3 },
C
C          the error SPICE(BADAXISNUMBERS) is signalled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     A word about notation:  the symbol
C
C        [ x ]
C             i
C
C     indicates a rotation of x radians about the ith coordinate axis.
C     To be specific, the symbol
C
C        [ x ]
C             1
C
C     indicates a coordinate system rotation of x radians about the
C     first, or x-, axis; the corresponding matrix is
C
C        +-                    -+
C        |  1      0       0    |
C        |                      |
C        |  0    cos(x)  sin(x) |.
C        |                      |
C        |  0   -sin(x)  cos(x) |
C        +-                    -+
C
C     Remember, this is a COORDINATE SYSTEM rotation by x radians; this
C     matrix, when applied to a vector, rotates the vector by -x
C     radians, not x radians.  Applying the matrix to a vector yields
C     the vector's representation relative to the rotated coordinate
C     system.
C
C     The analogous rotation about the second, or y-, axis is
C     represented by
C
C        [ x ]
C             2
C
C     which symbolizes the matrix
C
C        +-                    -+
C        | cos(x)   0   -sin(x) |
C        |                      |
C        |  0       1      0    |,
C        |                      |
C        | sin(x)   0    cos(x) |
C        +-                    -+
C
C     and the analogous rotation about the third, or z-, axis is
C     represented by
C
C        [ x ]
C             3
C
C     which symbolizes the matrix
C
C        +-                    -+
C        |  cos(x)  sin(x)   0  |
C        |                      |
C        | -sin(x)  cos(x)   0  |.
C        |                      |
C        |  0        0       1  |
C        +-                    -+
C
C     From time to time, (depending on one's line of work, perhaps) one
C     may happen upon a pair of coordinate systems related by a
C     sequence of rotations.  For example, the coordinate system
C     defined by an instrument such as a camera is sometime specified
C     by RA, DEC, and twist; if alpha, delta, and phi are the rotation
C     angles, then the series of rotations
C
C        [ phi ]     [ pi/2  -  delta ]     [ alpha ]
C               3                      2             3
C
C     produces a transformation from inertial to camera coordinates.
C
C     This routine is related to the SPICELIB routine M2EUL, which
C     produces a sequence of Euler angles, given a rotation matrix.
C     This routine is a `left inverse' of M2EUL:  the sequence of
C     calls
C
C        CALL M2EUL ( R,  AXIS3,   AXIS2,   AXIS1,
C       .                 ANGLE3,  ANGLE2,  ANGLE1     )
C
C        CALL EUL2M (     ANGLE3,  ANGLE2,  ANGLE1,
C       .                 AXIS3,   AXIS2,   AXIS1,   R )
C
C     preserves R, except for round-off error.
C
C
C     On the other hand, the sequence of calls
C
C        CALL EUL2M (     ANGLE3,  ANGLE2,  ANGLE1,
C       .                 AXIS3,   AXIS2,   AXIS1,   R )
C
C        CALL M2EUL ( R,  AXIS3,   AXIS2,   AXIS1,
C       .                 ANGLE3,  ANGLE2,  ANGLE1     )
C
C     preserve ANGLE3, ANGLE2, and ANGLE1 only if these angles start
C     out in the ranges that M2EUL's outputs are restricted to.
C
C$ Examples
C
C     1)  Create a coordinate transformation matrix by rotating
C         the original coordinate axes first by 30 degrees about
C         the z axis, next by 60 degrees about the y axis resulting
C         from the first rotation, and finally by -50 degrees about
C         the z axis resulting from the first two rotations.
C
C
C            C
C            C     Create the coordinate transformation matrix
C            C
C            C                   o          o          o
C            C        R  =  [ -50  ]   [  60  ]   [  30  ]
C            C                      3          2          3
C            C
C            C     All angles in radians, please.   The SPICELIB
C            C     function RPD (radians per degree) gives the
C            C     conversion factor.
C            C
C            C     The z axis is `axis 3'; the y axis is `axis 2'.
C            C
C                  ANGLE1 = RPD() *  30.D0
C                  ANGLE2 = RPD() *  60.D0
C                  ANGLE3 = RPD() * -50.D0
C
C                  AXIS1  = 3
C                  AXIS2  = 2
C                  AXIS3  = 3
C
C                  CALL EUL2M (  ANGLE3, ANGLE2, ANGLE1,
C                 .              AXIS3,  AXIS2,  AXIS1,   R  )
C
C
C     2)  A trivial example using actual numbers.
C
C         The code fragment
C
C            CALL EUL2M (  0.D0,     0.D0,     HALFPI(),
C           .                 1,        1,            3,      R  )
C
C         sets R equal to the matrix
C
C            +-                  -+
C            |  0      1       0  |
C            |                    |
C            | -1      0       0  |.
C            |                    |
C            |  0      0       1  |
C            +-                  -+
C
C
C     3)  Finding the rotation matrix specified by a set of `clock,
C         cone, and twist' angles, as defined on the Voyager 2 project:
C
C            Voyager 2 narrow angle camera pointing, relative to the
C            Sun-Canopus coordinate system, was frequently specified
C            by a set of Euler angles called `clock, cone, and twist'.
C            These defined a 3-2-3 coordinate transformation matrix
C            TSCTV as the product
C
C               [ twist ]  [ cone ]   [ clock ] .
C                        3         2           3
C
C            Given the angles CLOCK, CONE, and TWIST (in units of
C            radians), we can compute TSCTV with the code fragment
C
C               CALL EUL2M (  TWIST,  CONE,  CLOCK,
C              .              3,      2,     3,      TSCTV  )
C
C
C     4)  Finding the rotation matrix specified by a set of `right
C         ascension, declination, and twist' angles, as defined on the
C         Galileo project:
C
C            Galileo scan platform pointing, relative to an inertial
C            reference frame, (EME50 variety) is frequently specified
C            by a set of Euler angles called `right ascension (RA),
C            declination (Dec), and twist'. These define a 3-2-3
C            coordinate transformation matrix TISP as the product
C
C               [ Twist ]  [ pi/2 - Dec ]   [ RA ] .
C                        3               2        3
C
C            Given the angles RA, DEC, and TWIST (in units of radians),
C            we can compute TISP with the code fragment
C
C               CALL EUL2M (  TWIST,   HALFPI()-DEC,   RA,
C              .              3,       2,              3,   TISP  )
C
C
C$ Restrictions
C
C     Beware:  more than one definition of "RA, DEC and twist" exists.
C
C$ Literature_References
C
C     [1]  `Galileo Attitude and Camera Models', JPL IOM 314-323,
C           W. M. Owen, Jr.,  Nov. 11, 1983.  NAIF document number
C           204.0.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.2.1, 26-DEC-2006 (NJB)
C
C        Corrected header typo.
C
C-    SPICELIB Version 1.2.0, 25-AUG-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in ROTMAT calls.
C
C-    SPICELIB Version 1.1.2, 14-OCT-2004 (LSE)
C
C        Corrected a typo in the header.
C
C-    SPICELIB Version 1.1.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.1.0, 02-NOV-1990 (NJB)
C
C        Names of input arguments changed to reflect the order in
C        which the rotations are applied when their product is
C        computed.  The header was upgraded to describe notation in
C        more detail.  Examples were added.
C
C-    SPICELIB Version 1.0.0, 30-AUG-1990 (NJB)
C
C-&

C$ Index_Entries
C
C     euler angles to matrix
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.2.0, 25-AUG-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in ROTMAT calls.
C
C-    SPICELIB Version 1.1.0, 02-NOV-1990 (NJB)
C
C        Argument names were changed to describe the use of the
C        arguments more accurately.  The axis and angle numbers
C        now decrease, rather than increase, from left to right.
C        The current names reflect the order of operator application
C        when the Euler angle rotations are applied to a vector:  the
C        rightmost matrix
C
C           [ ANGLE1 ]
C                     AXIS1
C
C        is applied to the vector first, followed by
C
C           [ ANGLE2 ]
C                     AXIS2
C
C        and then
C
C           [ ANGLE3 ]
C                     AXIS3
C
C        Previously, the names reflected the order in which the Euler
C        angle matrices appear on the page, from left to right.  This
C        naming convention was found to be a bit obtuse by a various
C        users.
C
C        No change in functionality was made; the operation of the
C        routine is identical to that of the previous version.
C
C        Two new examples were added to assist users in verifying
C        their understanding of the routine.
C
C        Also, the header was upgraded to describe the notation in more
C        detail.  The symbol
C
C           [ x ]
C                i
C
C        is explained at mind-numbing length.  An example was added
C        that shows a specific set of inputs and the resulting output
C        matrix.
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN

C
C     Local variables
C
      DOUBLE PRECISION      R1    ( 3, 3 )
      LOGICAL               BADAX

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'EUL2M' )
      END IF

C
C     Make sure the axis numbers are all right:  They must belong to
C     the set {1, 2, 3}.
C
      BADAX =       (  ( AXIS3 .LT. 1 ) .OR. ( AXIS3 .GT. 3 )  )
     .         .OR. (  ( AXIS2 .LT. 1 ) .OR. ( AXIS2 .GT. 3 )  )
     .         .OR. (  ( AXIS1 .LT. 1 ) .OR. ( AXIS1 .GT. 3 )  )

      IF ( BADAX ) THEN

         CALL SETMSG ( 'Axis numbers are #,  #,  #. ' )
         CALL ERRINT ( '#',  AXIS3                    )
         CALL ERRINT ( '#',  AXIS2                    )
         CALL ERRINT ( '#',  AXIS1                    )
         CALL SIGERR ( 'SPICE(BADAXISNUMBERS)'        )
         CALL CHKOUT ( 'EUL2M'                        )
         RETURN

      END IF

C
C     Just do it.
C
      CALL ROTATE (      ANGLE1,  AXIS1,  R  )
      CALL ROTMAT ( R,   ANGLE2,  AXIS2,  R1 )
      CALL ROTMAT ( R1,  ANGLE3,  AXIS3,  R  )

      CALL CHKOUT ( 'EUL2M' )
      RETURN
      END