C
C     file hwscyl.f
C
      SUBROUTINE HWSCYL (A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,
     1                   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           BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N+1),
C ARGUMENTS              W(SEE ARGUMENT LIST)
C
C LATEST REVISION        NOVEMBER 1988
C
C PURPOSE                SOLVES A FINITE DIFFERENCE APPROXIMATION
C                        TO THE HELMHOLTZ EQUATION IN CYLINDRICAL
C                        COORDINATES.  THIS MODIFIED HELMHOLTZ EQUATION
C
C                          (1/R)(D/DR)(R(DU/DR)) + (D/DZ)(DU/DZ)
C
C                          + (LAMBDA/R**2)U = F(R,Z)
C
C                        RESULTS FROM THE FOURIER TRANSFORM OF THE
C                        THREE-DIMENSIONAL POISSON EQUATION.
C
C USAGE                  CALL HWSCYL (A,B,M,MBDCND,BDA,BDB,C,D,N,
C                                     NBDCND,BDC,BDD,ELMBDA,F,IDIMF,
C                                     PERTRB,IERROR,W)
C
C ARGUMENTS
C ON INPUT               A,B
C                          THE RANGE OF R, I.E., A .LE. R .LE. B.
C                          A MUST BE LESS THAN B AND A MUST BE
C                          NON-NEGATIVE.
C
C                        M
C                          THE NUMBER OF PANELS INTO WHICH THE
C                          INTERVAL (A,B) IS SUBDIVIDED.  HENCE,
C                          THERE WILL BE M+1 GRID POINTS IN THE
C                          R-DIRECTION GIVEN BY R(I) = A+(I-1)DR,
C                          FOR I = 1,2,...,M+1, WHERE DR = (B-A)/M
C                          IS THE PANEL WIDTH. M MUST BE GREATER
C                          THAN 3.
C
C                        MBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITIONS
C                          AT R = A AND R = B.
C
C                          = 1  IF THE SOLUTION IS SPECIFIED AT
C                               R = A AND R = B.
C                          = 2  IF THE SOLUTION IS SPECIFIED AT
C                               R = A AND THE DERIVATIVE OF THE
C                               SOLUTION WITH RESPECT TO R IS
C                               SPECIFIED AT R = B.
C                          = 3  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO R IS SPECIFIED AT
C                               R = A (SEE NOTE BELOW) AND R = B.
C                          = 4  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO R IS SPECIFIED AT
C                               R = A (SEE NOTE BELOW) AND THE
C                               SOLUTION IS SPECIFIED AT R = B.
C                          = 5  IF THE SOLUTION IS UNSPECIFIED AT
C                               R = A = 0 AND THE SOLUTION IS
C                               SPECIFIED AT R = B.
C                          = 6  IF THE SOLUTION IS UNSPECIFIED AT
C                               R = A = 0 AND THE DERIVATIVE OF THE
C                               SOLUTION WITH RESPECT TO R IS SPECIFIED
C                               AT R = B.
C
C                          IF A = 0, DO NOT USE MBDCND = 3 OR 4,
C                          BUT INSTEAD USE MBDCND = 1,2,5, OR 6  .
C
C                        BDA
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT
C                          SPECIFIES THE VALUES OF THE DERIVATIVE OF
C                          THE SOLUTION WITH RESPECT TO R AT R = A.
C
C                          WHEN MBDCND = 3 OR 4,
C                            BDA(J) = (D/DR)U(A,Z(J)), J = 1,2,...,N+1.
C
C                          WHEN MBDCND HAS ANY OTHER VALUE, BDA IS
C                          A DUMMY VARIABLE.
C
C                        BDB
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT
C                          SPECIFIES THE VALUES OF THE DERIVATIVE
C                          OF THE SOLUTION WITH RESPECT TO R AT R = B.
C
C                          WHEN MBDCND = 2,3, OR 6,
C                            BDB(J) = (D/DR)U(B,Z(J)), J = 1,2,...,N+1.
C
C                          WHEN MBDCND HAS ANY OTHER VALUE, BDB IS
C                          A DUMMY VARIABLE.
C
C                        C,D
C                          THE RANGE OF Z, I.E., C .LE. Z .LE. D.
C                          C MUST BE LESS THAN D.
C
C                        N
C                          THE NUMBER OF PANELS INTO WHICH THE
C                          INTERVAL (C,D) IS SUBDIVIDED.  HENCE,
C                          THERE WILL BE N+1 GRID POINTS IN THE
C                          Z-DIRECTION GIVEN BY Z(J) = C+(J-1)DZ,
C                          FOR J = 1,2,...,N+1,
C                          WHERE DZ = (D-C)/N IS THE PANEL WIDTH.
C                          N MUST BE GREATER THAN 3.
C
C                        NBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITIONS
C                          AT Z = C AND Z = D.
C
C                          = 0  IF THE SOLUTION IS PERIODIC IN Z,
C                               I.E., U(I,1) = U(I,N+1).
C                          = 1  IF THE SOLUTION IS SPECIFIED AT
C                               Z = C AND Z = D.
C                          = 2  IF THE SOLUTION IS SPECIFIED AT
C                               Z = C AND THE DERIVATIVE OF
C                               THE SOLUTION WITH RESPECT TO Z IS
C                               SPECIFIED AT Z = D.
C                          = 3  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO Z IS
C                               SPECIFIED AT Z = C AND Z = D.
C                          = 4  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO Z IS SPECIFIED AT
C                               Z = C AND THE SOLUTION IS SPECIFIED
C                               AT Z = D.
C
C                        BDC
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT
C                          SPECIFIES THE VALUES OF THE DERIVATIVE
C                          OF THE SOLUTION WITH RESPECT TO Z AT Z = C.
C
C                          WHEN NBDCND = 3 OR 4,
C                            BDC(I) = (D/DZ)U(R(I),C), I = 1,2,...,M+1.
C
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDC IS
C                          A DUMMY VARIABLE.
C
C                        BDD
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT
C                          SPECIFIES THE VALUES OF THE DERIVATIVE OF
C                          THE SOLUTION WITH RESPECT TO Z AT Z = D.
C
C                          WHEN NBDCND = 2 OR 3,
C                            BDD(I) = (D/DZ)U(R(I),D), I = 1,2,...,M+1
C
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDD 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, HWSCYL WILL
C                          ATTEMPT TO FIND A SOLUTION.  LAMBDA MUST
C                          BE ZERO WHEN MBDCND = 5 OR 6  .
C
C                        F
C                          A TWO-DIMENSIONAL ARRAY, OF DIMENSION AT
C                          LEAST (M+1)*(N+1), SPECIFYING VALUES
C                          OF THE RIGHT SIDE OF THE HELMHOLTZ
C                          EQUATION AND BOUNDARY DATA (IF ANY).
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(R(I),Z(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(A,Z(J))         U(B,Z(J))
C                            2      U(A,Z(J))         F(B,Z(J))
C                            3      F(A,Z(J))         F(B,Z(J))
C                            4      F(A,Z(J))         U(B,Z(J))
C                            5      F(0,Z(J))         U(B,Z(J))
C                            6      F(0,Z(J))         F(B,Z(J))
C
C                          NBDCND   F(I,1)            F(I,N+1)
C                          ------   ---------         ---------
C
C                            0      F(R(I),C)         F(R(I),C)
C                            1      U(R(I),C)         U(R(I),D)
C                            2      U(R(I),C)         F(R(I),D)
C                            3      F(R(I),C)         F(R(I),D)
C                            4      F(R(I),C)         U(R(I),D)
C
C                          NOTE:
C                          IF THE TABLE CALLS FOR BOTH THE SOLUTION
C                          U AND THE RIGHT SIDE F AT A CORNER THEN
C                          THE 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                          HWSCYL.  THIS PARAMETER IS USED TO SPECIFY
C                          THE VARIABLE DIMENSION OF F.  IDIMF MUST
C                          BE 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 4*(N+1) +
C                          (13 + INT(LOG2(N+1)))*(M+1) LOCATIONS.
C                          THE ACTUAL NUMBER OF LOCATIONS USED IS
C                          COMPUTED BY HWSCYL AND IS RETURNED IN
C                          LOCATION W(1).
C
C
C ON OUTPUT              F
C                          CONTAINS THE SOLUTION U(I,J) OF THE FINITE
C                          DIFFERENCE APPROXIMATION FOR THE GRID POINT
C                          (R(I),Z(J)), I =1,2,...,M+1, J =1,2,...,N+1.
C
C                        PERTRB
C                          IF ONE SPECIFIES A COMBINATION OF PERIODIC,
C                          DERIVATIVE, AND 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.  HWSCYL THEN COMPUTES
C                          THIS SOLUTION, WHICH IS A LEAST SQUARES
C                          SOLUTION TO THE ORIGINAL APPROXIMATION.
C                          THIS SOLUTION PLUS ANY CONSTANT IS ALSO
C                          A SOLUTION.  HENCE, THE SOLUTION IS NOT
C                          UNIQUE. THE VALUE OF PERTRB SHOULD BE
C                          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 OBTAINED.
C
C                        IERROR
C                          AN ERROR FLAG WHICH INDICATES INVALID INPUT
C                          PARAMETERS.  EXCEPT FOR NUMBERS 0 AND 11,
C                          A SOLUTION IS NOT ATTEMPTED.
C
C                          =  0  NO ERROR.
C                          =  1  A .LT. 0  .
C                          =  2  A .GE. B.
C                          =  3  MBDCND .LT. 1 OR MBDCND .GT. 6  .
C                          =  4  C .GE. D.
C                          =  5  N .LE. 3
C                          =  6  NBDCND .LT. 0 OR NBDCND .GT. 4  .
C                          =  7  A = 0, MBDCND = 3 OR 4  .
C                          =  8  A .GT. 0, MBDCND .GE. 5  .
C                          =  9  A = 0, LAMBDA .NE. 0, MBDCND .GE. 5  .
C                          = 10  IDIMF .LT. M+1  .
C                          = 11  LAMBDA .GT. 0  .
C                          = 12  M .LE. 3
C
C                          SINCE THIS IS THE ONLY MEANS OF INDICATING
C                          A POSSIBLY INCORRECT CALL TO HWSCYL, THE
C                          USER SHOULD TEST IERROR AFTER THE CALL.
C
C                        W
C                          W(1) CONTAINS THE REQUIRED 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             SWARZTRAUBER,P. AND R. SWEET, "EFFICIENT
C                        FORTRAN SUBPROGRAMS FOR THE SOLUTION OF
C                        ELLIPTIC EQUATIONS"
C                          NCAR TN/IA-109, JULY, 1975, 138 PP.
C***********************************************************************
      DIMENSION       F(IDIMF,*)
      DIMENSION       BDA(*)     ,BDB(*)     ,BDC(*)     ,BDD(*)     ,
     1                W(*)
C
C     CHECK FOR INVALID PARAMETERS.
C
      IERROR = 0
      IF (A .LT. 0.) IERROR = 1
      IF (A .GE. B) IERROR = 2
      IF (MBDCND.LE.0 .OR. MBDCND.GE.7) IERROR = 3
      IF (C .GE. D) IERROR = 4
      IF (N .LE. 3) IERROR = 5
      IF (NBDCND.LE.-1 .OR. NBDCND.GE.5) IERROR = 6
      IF (A.EQ.0. .AND. (MBDCND.EQ.3 .OR. MBDCND.EQ.4)) IERROR = 7
      IF (A.GT.0. .AND. MBDCND.GE.5) IERROR = 8
      IF (A.EQ.0. .AND. ELMBDA.NE.0. .AND. MBDCND.GE.5) IERROR = 9
      IF (IDIMF .LT. M+1) IERROR = 10
      IF (M .LE. 3) IERROR = 12
      IF (IERROR .NE. 0) RETURN
      MP1 = M+1
      DELTAR = (B-A)/FLOAT(M)
      DLRBY2 = DELTAR/2.
      DLRSQ = DELTAR**2
      NP1 = N+1
      DELTHT = (D-C)/FLOAT(N)
      DLTHSQ = DELTHT**2
      NP = NBDCND+1
C
C     DEFINE RANGE OF INDICES I AND J FOR UNKNOWNS U(I,J).
C
      MSTART = 2
      MSTOP = M
      GO TO (104,103,102,101,101,102),MBDCND
  101 MSTART = 1
      GO TO 104
  102 MSTART = 1
  103 MSTOP = MP1
  104 MUNK = MSTOP-MSTART+1
      NSTART = 1
      NSTOP = N
      GO TO (108,105,106,107,108),NP
  105 NSTART = 2
      GO TO 108
  106 NSTART = 2
  107 NSTOP = NP1
  108 NUNK = NSTOP-NSTART+1
C
C     DEFINE A,B,C COEFFICIENTS IN W-ARRAY.
C
      ID2 = MUNK
      ID3 = ID2+MUNK
      ID4 = ID3+MUNK
      ID5 = ID4+MUNK
      ID6 = ID5+MUNK
      ISTART = 1
      A1 = 2./DLRSQ
      IJ = 0
      IF (MBDCND.EQ.3 .OR. MBDCND.EQ.4) IJ = 1
      IF (MBDCND .LE. 4) GO TO 109
      W(1) = 0.
      W(ID2+1) = -2.*A1
      W(ID3+1) = 2.*A1
      ISTART = 2
      IJ = 1
  109 DO 110 I=ISTART,MUNK
         R = A+FLOAT(I-IJ)*DELTAR
         J = ID5+I
         W(J) = R
         J = ID6+I
         W(J) = 1./R**2
         W(I) = (R-DLRBY2)/(R*DLRSQ)
         J = ID3+I
         W(J) = (R+DLRBY2)/(R*DLRSQ)
         K = ID6+I
         J = ID2+I
         W(J) = -A1+ELMBDA*W(K)
  110 CONTINUE
      GO TO (114,111,112,113,114,112),MBDCND
  111 W(ID2) = A1
      GO TO 114
  112 W(ID2) = A1
  113 W(ID3+1) = A1*FLOAT(ISTART)
  114 CONTINUE
C
C     ENTER BOUNDARY DATA FOR R-BOUNDARIES.
C
      GO TO (115,115,117,117,119,119),MBDCND
  115 A1 = W(1)
      DO 116 J=NSTART,NSTOP
         F(2,J) = F(2,J)-A1*F(1,J)
  116 CONTINUE
      GO TO 119
  117 A1 = 2.*DELTAR*W(1)
      DO 118 J=NSTART,NSTOP
         F(1,J) = F(1,J)+A1*BDA(J)
  118 CONTINUE
  119 GO TO (120,122,122,120,120,122),MBDCND
  120 A1 = W(ID4)
      DO 121 J=NSTART,NSTOP
         F(M,J) = F(M,J)-A1*F(MP1,J)
  121 CONTINUE
      GO TO 124
  122 A1 = 2.*DELTAR*W(ID4)
      DO 123 J=NSTART,NSTOP
         F(MP1,J) = F(MP1,J)-A1*BDB(J)
  123 CONTINUE
C
C     ENTER BOUNDARY DATA FOR Z-BOUNDARIES.
C
  124 A1 = 1./DLTHSQ
      L = ID5-MSTART+1
      GO TO (134,125,125,127,127),NP
  125 DO 126 I=MSTART,MSTOP
         F(I,2) = F(I,2)-A1*F(I,1)
  126 CONTINUE
      GO TO 129
  127 A1 = 2./DELTHT
      DO 128 I=MSTART,MSTOP
         F(I,1) = F(I,1)+A1*BDC(I)
  128 CONTINUE
  129 A1 = 1./DLTHSQ
      GO TO (134,130,132,132,130),NP
  130 DO 131 I=MSTART,MSTOP
         F(I,N) = F(I,N)-A1*F(I,NP1)
  131 CONTINUE
      GO TO 134
  132 A1 = 2./DELTHT
      DO 133 I=MSTART,MSTOP
         F(I,NP1) = F(I,NP1)-A1*BDD(I)
  133 CONTINUE
  134 CONTINUE
C
C     ADJUST RIGHT SIDE OF SINGULAR PROBLEMS TO INSURE EXISTENCE OF A
C     SOLUTION.
C
      PERTRB = 0.
      IF (ELMBDA) 146,136,135
  135 IERROR = 11
      GO TO 146
  136 W(ID5+1) = .5*(W(ID5+2)-DLRBY2)
      GO TO (146,146,138,146,146,137),MBDCND
  137 W(ID5+1) = .5*W(ID5+1)
  138 GO TO (140,146,146,139,146),NP
  139 A2 = 2.
      GO TO 141
  140 A2 = 1.
  141 K = ID5+MUNK
      W(K) = .5*(W(K-1)+DLRBY2)
      S = 0.
      DO 143 I=MSTART,MSTOP
         S1 = 0.
         NSP1 = NSTART+1
         NSTM1 = NSTOP-1
         DO 142 J=NSP1,NSTM1
            S1 = S1+F(I,J)
  142    CONTINUE
         K = I+L
         S = S+(A2*S1+F(I,NSTART)+F(I,NSTOP))*W(K)
  143 CONTINUE
      S2 = FLOAT(M)*A+(.75+FLOAT((M-1)*(M+1)))*DLRBY2
      IF (MBDCND .EQ. 3) S2 = S2+.25*DLRBY2
      S1 = (2.+A2*FLOAT(NUNK-2))*S2
      PERTRB = S/S1
      DO 145 I=MSTART,MSTOP
         DO 144 J=NSTART,NSTOP
            F(I,J) = F(I,J)-PERTRB
  144    CONTINUE
  145 CONTINUE
  146 CONTINUE
C
C     MULTIPLY I-TH EQUATION THROUGH BY DELTHT**2 TO PUT EQUATION INTO
C     CORRECT FORM FOR SUBROUTINE GENBUN.
C
      DO 148 I=MSTART,MSTOP
         K = I-MSTART+1
         W(K) = W(K)*DLTHSQ
         J = ID2+K
         W(J) = W(J)*DLTHSQ
         J = ID3+K
         W(J) = W(J)*DLTHSQ
         DO 147 J=NSTART,NSTOP
            F(I,J) = F(I,J)*DLTHSQ
  147    CONTINUE
  148 CONTINUE
      W(1) = 0.
      W(ID4) = 0.
C
C     CALL GENBUN TO SOLVE THE SYSTEM OF EQUATIONS.
C
      CALL GENBUN (NBDCND,NUNK,1,MUNK,W(1),W(ID2+1),W(ID3+1),IDIMF,
     1             F(MSTART,NSTART),IERR1,W(ID4+1))
      W(1) = W(ID4+1)+3.*FLOAT(MUNK)
      IF (NBDCND .NE. 0) GO TO 150
      DO 149 I=MSTART,MSTOP
         F(I,NP1) = F(I,1)
  149 CONTINUE
  150 CONTINUE
      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


      SUBROUTINE IFTE2(THA,RP,CP)
      DATA THAO,EPSI /.1,1.E-9 /
      IF(ABS(THA) .LT. THAO ) GO TO 100
      D = .5* THA*THA
      RP = (1. - COS(THA))/D
      CP = (THA - SIN(THA))/D
      RETURN
C
C     EVALUATE SERIES
C
  100 CONTINUE
      RN = 1.0
      D = 1.0
      SIGN = -1.
      RPS = 1.0
      TSQ = THA*THA
      T1=3.
      T2=4.
      IT = 1
  101 CONTINUE
      DO 110 I=1,50
      RN = RN*TSQ
      D = D*T1*T2
      TRM = RN/D*SIGN
      RPS = RPS+TRM
      IF(ABS(TRM) .LT. EPSI) GO TO 120
      SIGN = -SIGN
      T1 = T1+2.
      T2 = T2+2.
  110 CONTINUE
  120 CONTINUE
      IF(IT .EQ. 2) GO TO 125
      RP = RPS
      RN = THA
      D = 3.0
      SIGN = -1.
      RPS = THA/3.
      T1 = 4.
      T2 = 5.
      IT = 2
      GO TO 101
  125 CONTINUE
      CP = RPS
      RETURN
      END


*dk,inv2x2
      subroutine inv2x2(a11,a21,a12,a22,x1,x2,b1,b2,epsilon)
C
C ######################################################################
C
C     PURPOSE -
C
C        Solv the 2x2 problem a x = b for x
C
C     INPUT ARGUMENTS -
C
C        a11,a21,a12,a22 - the a matrix
C        b1,b2           - the b vector
C        epsilon         - relative epsilon for small tests
C
C     OUTPUT ARGUMENTS -
C
C        x1,x2 - the solution vector
C
C     PROGRAMMING NOTES -
C
C        to handle "nearly singular" matrix, the
C        Cramers Rule soln is compared to
C        the Schmidt-Hilbert soln.
C        If the magnitudes differ widly
C        the Schmidt-Hilbert soln is used.
C
C     CHANGE HISTORY -
C
C        $Log: inv2x2.f,v $
C        Revision 2.00  2007/11/03 00:49:11  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.3   Tue Oct 19 14:58:56 1999   jtg
CPVCS    fixed local_debug flag (was non-zero)
CPVCS
CPVCS       Rev 1.2   Tue Oct 19 12:59:42 1999   jtg
CPVCS    If singular, it now finds the best solution instead of
CPVCS    returning "1/epsilon", using Schmidt-Hilbert to
CPVCS    solve the singular problem.
CPVCS
CPVCS       Rev 1.1   01/04/95 21:55:30   llt
CPVCS    unicos changes (made by het)
CPVCS
CPVCS       Rev 1.0   11/15/94 16:50:24   llt
CPVCS    Original version
C
C ######################################################################
C
      implicit none
      real*8 a11,a12,a21,a22,b1,b2,
     &                  x1,x2,epsilon

      integer iflag,i1,i,local_debug

      real*8 mat(2,2),matinv(2,2),s1,s2,xxx,sss
     &       ,iarb(2),arb(2,2),work(2,2),scale,det

C-----------------------------------------------------------------------

      xxx=abs(b1)
      if (xxx.lt.abs(b2)) xxx=abs(b2)

      ! do nothing if vec==0
      if (xxx.eq.0.d0) then
         x1=0.d0
         x2=0.d0
         goto 100
      endif

      mat(1,1)=a11
      mat(2,1)=a21
      mat(1,2)=a12
      mat(2,2)=a22

      ! calculate determinant and adjoint
      scale=0.d0
      det=0.d0
      i=1
      i1=2
      xxx=mat(1,i)*mat(2,i1)
      if (abs(xxx).gt.scale) scale=abs(xxx)
      det=det+xxx
      xxx=mat(1,i1)*mat(2,i)
      if (abs(xxx).gt.scale) scale=abs(xxx)
      det=det-xxx
      matinv(1,1)=mat(2,2)
      matinv(2,2)=mat(1,1)
      matinv(1,2)=-mat(1,2)
      matinv(2,1)=-mat(2,1)

      ! calculate soln using inverse=adjoint/determinant (Cramer's rule)

      if (det.ne.0.d0) then
         x1=matinv(1,1)*b1+matinv(1,2)*b2
         x1=x1/det
         x2=matinv(2,1)*b1+matinv(2,2)*b2
         x2=x2/det
      endif

      if (abs(det).le.epsilon*scale.or.det.eq.0.d0) then

         ! if (nearly) singular, compare to Schmidt-Hilbert soln and
         ! use that instead if magnitudes vastly different

         call inv_schmidt_hilbert_lg
     &          (epsilon,2,2,2,2
     &           ,mat,matinv,iarb,arb,work)

         if (det.ne.0.d0) then
            s1=matinv(1,1)*b1+matinv(1,2)*b2
            s2=matinv(2,1)*b1+matinv(2,2)*b2
            xxx=abs(x1)+abs(x2)
            sss=abs(s1)+abs(s2)
            if (xxx*epsilon.gt.sss) then
               ! presume that what the user really wanted was
               ! the schmidt_hilbert soln of the (nearly) singular matrix
               x1=s1
               x2=s2
               iflag=1
            endif
         else
            x1=matinv(1,1)*b1+matinv(1,2)*b2
            x2=matinv(2,1)*b1+matinv(2,2)*b2
         endif

      endif

      !local_debug=0
      !if (local_debug.gt.0) then
      !   write(*,*) x1,x2,a11*x1+a12*x2-b1,a21*x1+a22*x2-b2
      !endif

100   return
      end


Function asinh(x)
  Save
  If (x>0) Then
    asinh = alog(x+sqrt(x**2+1.))
  Else
    asinh = -alog(-x+sqrt(x**2+1.))
  End If
  Return
End Function asinh


PROGRAM mcyzo

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:10

!     ===========================================================
!     Purpose : This program evaluates the complex zeros of
!     Y0(z), Y0'(z), Y1(z) and Y1'(z), and their
!     associated values at the zeros using the
!     modified Newton's iteration method
!     Input:    NT --- Total number of roots/zeros
!     KF --- Function choice code
!     KF=0 for  Y0(z) & Y1(z0)
!     KF=1 for  Y1(z) & Y0(z1)
!     KF=2 for  Y1'(z) & Y1(z1')
!     KC --- Choice code
!     KC=0 for complex roots
!     KC=1 for real roots
!     Output:   ZO(L) --- L-th zero of Y0(z) or Y1(z) or Y1'(z)
!     ZV(L) --- Value of Y0'(z) or Y1'(z) or Y1(z)
!     at the L-th zero
!     Examples: NT = 5

!     No.      z0, Zeros of Y0(z)                Y1(z0)
!     -----------------------------------------------------------------
!     1   -2.403016632 + i .5398823130   .1007476893 - i .8819677101
!     2   -5.519876702 + i .5471800106  -.0292464182 + i .5871695027
!     3   -8.653672403 + i .5484120673   .0149080637 - i .4694587524
!     4  -11.791512030 + i .5488191184  -.0093736817 + i .4023045429
!     5  -14.930906564 + i .5490008289   .0065788031 - i .3575673214

!     No.      z1, Zeros of Y1(z)                 Y0(z1)
!     -----------------------------------------------------------------
!     1    -.502743273 + i .7862437145  -.4595276847 + i1.3171019361
!     2   -3.833535193 + i .5623565382   .0483019087 - i .6925128842
!     3   -7.015903683 + i .5533930459  -.0201269494 + i .5186425332
!     4  -10.173573834 + i .5512733877   .0116140017 - i .4320329636
!     5  -13.323739307 + i .5504585830  -.0077719300 + i .3779698048

!     No.      z1', Zeros of Y1'(z)                Y1(z1')
!     ----------------------------------------------------------------
!     1     .576785129 + i .9039847922  -.7634970879 + i .5892448647
!     2   -1.940477342 - i .7211859189   .1620640057 + i .9520278864
!     3   -5.333478617 - i .5672196368  -.0317940081 - i .5968536736
!     4   -8.536768577 - i .5560607040   .0154177166 + i .4726011652
!     5  -11.706175219 - i .5528590607  -.0095443768 - i .4037533396
!     ============================================================

IMPLICIT COMPLEX *16 (z)
DIMENSION zo(50),zv(50)
WRITE(*,*)'Please Enter NT, KF and KC'
WRITE(*,*)'  NT --- Total number of the roots'
WRITE(*,*)'  KF  --- Function choice code'
WRITE(*,*)'          KF=0 for Y0(z) & Y1(z0)'
WRITE(*,*)'          KF=1 for Y1(z) & Y0(z1)'
WRITE(*,*)'          KF=2 for Y1''(Z) & Y1(Z1'')'
WRITE(*,*)'  KC  --- Choice code'
WRITE(*,*)'          KC=0 for complex roots'
WRITE(*,*)'          KC=1 for real roots'
!     READ(*,*)NT,KF,KC
nt=5
kf=1
kc=0
WRITE(*,20)nt,kf,kc
WRITE(*,*)
WRITE(*,15)
CALL cyzo(nt,kf,kc,zo,zv)
WRITE(*,*)
IF (kf == 0) THEN
  WRITE(*,*)' No.          z0, Zeros of Y0(z)', '                 Y1(z0)'
ELSE IF (kf == 1) THEN
  WRITE(*,*)' No.          z1, Zeros of Y1(z)', '                 Y0(z1)'
ELSE IF (kf == 2) THEN
  WRITE(*,*)' No.        z1'', ZEROS OF Y1''(Z)', '                Y1(z1'')'
END IF
WRITE(*,*)'--------------------------------------',  &
    '----------------------------'
DO  i=1,nt
  WRITE(*,25)i,zo(i),zv(i)
END DO
15   FORMAT(20X,'*****    Please Wait     *****')
20   FORMAT(2X,'NT=',i3,',  ','KF=',i3,',  ','KC=',i3)
25   FORMAT(1X,i3,2X,f15.9,3F15.10)
END PROGRAM mcyzo

SUBROUTINE cyzo(nt,kf,kc,zo,zv)

!     ===========================================================
!     Purpose : Compute the complex zeros of Y0(z), Y1(z) and
!     Y1'(z), and their associated values at the zeros
!     using the modified Newton's iteration method
!     Input:    NT --- Total number of zeros/roots
!     KF --- Function choice code
!     KF=0 for  Y0(z) & Y1(z0)
!     KF=1 for  Y1(z) & Y0(z1)
!     KF=2 for  Y1'(z) & Y1(z1')
!     KC --- Choice code
!     KC=0 for complex roots
!     KC=1 for real roots
!     Output:   ZO(L) --- L-th zero of Y0(z) or Y1(z) or Y1'(z)
!     ZV(L) --- Value of Y0'(z) or Y1'(z) or Y1(z)
!     at the L-th zero
!     Routine called: CY01 for computing Y0(z) and Y1(z), and
!     their derivatives
!     ===========================================================

INTEGER, INTENT(IN)                      :: nt
INTEGER, INTENT(IN)                      :: kf
INTEGER, INTENT(IN)                      :: kc
COMPLEX, INTENT(IN OUT)                  :: zo(nt)
COMPLEX, INTENT(OUT)                     :: zv(nt)
IMPLICIT DOUBLE PRECISION (h,o-y)
IMPLICIT COMPLEX*16 (c,z)

w=0.0
IF (kc == 0) THEN
  x=-2.4D0
  y=0.54D0
  h=3.14
ELSE IF (kc == 1) THEN
  x=0.89
  y=0.0
  h=-3.14
END IF
IF (kf == 1) x=-0.503
IF (kf == 2) x=0.577
zero=CMPLX(x,y)
z=zero
DO  nr=1,nt
  10    IF (nr /= 1) z=zo(nr-1)-h
  it=0
  DO
    15     it=it+1
    CALL cy01(kf,z,zf,zd)
    zp=(1.0D0,0.0D0)
    DO  i=1,nr-1
      zp=zp*(z-zo(i))
    END DO
    zfd=zf/zp
    zq=(0.0D0,0.0D0)
    DO  i=1,nr-1
      zw=(1.0D0,0.0D0)
      DO  j=1,nr-1
        IF (.NOT.(j == i)) THEN
          zw=zw*(z-zo(j))
        END IF
      END DO
      zq=zq+zw
    END DO
    zgd=(zd-zq*zfd)/zp
    z=z-zfd/zgd
    w0=w
    w=CDABS(z)
    IF (.NOT.(it <= 50.AND.DABS((w-w0)/w) > 1.0D-12)) EXIT
  END DO
  zo(nr)=z
END DO
DO  i=1,nt
  z=zo(i)
  IF (kf == 0.OR.kf == 2) THEN
    CALL cy01(1,z,zf,zd)
    zv(i)=zf
  ELSE IF (kf == 1) THEN
    CALL cy01(0,z,zf,zd)
    zv(i)=zf
  END IF
END DO
RETURN
END SUBROUTINE cyzo

SUBROUTINE cy01(kf,z,zf,zd)

!     ===========================================================
!     Purpose: Compute complex Bessel functions Y0(z), Y1(z)
!     and their derivatives
!     Input :  z  --- Complex argument of Yn(z) ( n=0,1 )
!     KF --- Function choice code
!     KF=0 for ZF=Y0(z) and ZD=Y0'(z)
!     KF=1 for ZF=Y1(z) and ZD=Y1'(z)
!     KF=2 for ZF=Y1'(z) and ZD=Y1''(z)
!     Output:  ZF --- Y0(z) or Y1(z) or Y1'(z)
!     ZD --- Y0'(z) or Y1'(z) or Y1''(z)
!     ===========================================================

INTEGER, INTENT(IN OUT)                  :: kf
COMPLEX, INTENT(IN)                      :: z
COMPLEX, INTENT(OUT)                     :: zf
COMPLEX, INTENT(OUT)                     :: zd
IMPLICIT DOUBLE PRECISION (a,b,e,p,r,w)
IMPLICIT COMPLEX*16 (c,z)
DIMENSION a(12),b(12),a1(12),b1(12)

pi=3.141592653589793D0
el=0.5772156649015329D0
rp2=2.0D0/pi
ci=(0.0D0,1.0D0)
a0=CDABS(z)
z2=z*z
z1=z
IF (a0 == 0.0D0) THEN
  cbj0=(1.0D0,0.0D0)
  cbj1=(0.0D0,0.0D0)
  cby0=-(1.0D300,0.0D0)
  cby1=-(1.0D300,0.0D0)
  cdy0=(1.0D300,0.0D0)
  cdy1=(1.0D300,0.0D0)
ELSE
  IF (REAL(z) < 0.0) z1=-z
  IF (a0 <= 12.0) THEN
    cbj0=(1.0D0,0.0D0)
    cr=(1.0D0,0.0D0)
    DO  k=1,40
      cr=-0.25D0*cr*z2/(k*k)
      cbj0=cbj0+cr
      IF (CDABS(cr) < CDABS(cbj0)*1.0D-15) EXIT
    END DO
    15     cbj1=(1.0D0,0.0D0)
    cr=(1.0D0,0.0D0)
    DO  k=1,40
      cr=-0.25D0*cr*z2/(k*(k+1.0D0))
      cbj1=cbj1+cr
      IF (CDABS(cr) < CDABS(cbj1)*1.0D-15) EXIT
    END DO
    25     cbj1=0.5D0*z1*cbj1
    w0=0.0D0
    cr=(1.0D0,0.0D0)
    cs=(0.0D0,0.0D0)
    DO  k=1,40
      w0=w0+1.0D0/k
      cr=-0.25D0*cr/(k*k)*z2
      cp=cr*w0
      cs=cs+cp
      IF (CDABS(cp) < CDABS(cs)*1.0D-15) EXIT
    END DO
    35     cby0=rp2*(CDLOG(z1/2.0D0)+el)*cbj0-rp2*cs
    w1=0.0D0
    cr=(1.0D0,0.0D0)
    cs=(1.0D0,0.0D0)
    DO  k=1,40
      w1=w1+1.0D0/k
      cr=-0.25D0*cr/(k*(k+1))*z2
      cp=cr*(2.0D0*w1+1.0D0/(k+1.0D0))
      cs=cs+cp
      IF (CDABS(cp) < CDABS(cs)*1.0D-15) EXIT
    END DO
    45     cby1=rp2*((CDLOG(z1/2.0D0)+el)*cbj1-1.0D0/z1-.25D0*z1*cs)
  ELSE
    DATA a/-.703125D-01,.112152099609375D+00,  &
        -.5725014209747314D+00,.6074042001273483D+01,  &
        -.1100171402692467D+03,.3038090510922384D+04,  &
        -.1188384262567832D+06,.6252951493434797D+07,  &
        -.4259392165047669D+09,.3646840080706556D+11,  &
        -.3833534661393944D+13,.4854014686852901D+15/
    DATA b/ .732421875D-01,-.2271080017089844D+00,  &
        .1727727502584457D+01,-.2438052969955606D+02,  &
        .5513358961220206D+03,-.1825775547429318D+05,  &
        .8328593040162893D+06,-.5006958953198893D+08,  &
        .3836255180230433D+10,-.3649010818849833D+12,  &
        .4218971570284096D+14,-.5827244631566907D+16/
    DATA a1/.1171875D+00,-.144195556640625D+00,  &
        .6765925884246826D+00,-.6883914268109947D+01,  &
        .1215978918765359D+03,-.3302272294480852D+04,  &
        .1276412726461746D+06,-.6656367718817688D+07,  &
        .4502786003050393D+09,-.3833857520742790D+11,  &
        .4011838599133198D+13,-.5060568503314727D+15/
    DATA b1/-.1025390625D+00,.2775764465332031D+00,  &
        -.1993531733751297D+01,.2724882731126854D+02,  &
        -.6038440767050702D+03,.1971837591223663D+05,  &
        -.8902978767070678D+06,.5310411010968522D+08,  &
        -.4043620325107754D+10,.3827011346598605D+12,  &
        -.4406481417852278D+14,.6065091351222699D+16/
    k0=12
    IF (a0 >= 35.0) k0=10
    IF (a0 >= 50.0) k0=8
    ct1=z1-.25D0*pi
    cp0=(1.0D0,0.0D0)
    DO  k=1,k0
      cp0=cp0+a(k)*z1**(-2*k)
    END DO
    cq0=-0.125D0/z1
    DO  k=1,k0
      cq0=cq0+b(k)*z1**(-2*k-1)
    END DO
    cu=CDSQRT(rp2/z1)
    cbj0=cu*(cp0*CDCOS(ct1)-cq0*CDSIN(ct1))
    cby0=cu*(cp0*CDSIN(ct1)+cq0*CDCOS(ct1))
    ct2=z1-.75D0*pi
    cp1=(1.0D0,0.0D0)
    DO  k=1,k0
      cp1=cp1+a1(k)*z1**(-2*k)
    END DO
    cq1=0.375D0/z1
    DO  k=1,k0
      cq1=cq1+b1(k)*z1**(-2*k-1)
    END DO
    cbj1=cu*(cp1*CDCOS(ct2)-cq1*CDSIN(ct2))
    cby1=cu*(cp1*CDSIN(ct2)+cq1*CDCOS(ct2))
  END IF
  IF (REAL(z) < 0.0) THEN
    IF (DIMAG(z) < 0.0) cby0=cby0-2.0D0*ci*cbj0
    IF (DIMAG(z) > 0.0) cby0=cby0+2.0D0*ci*cbj0
    IF (DIMAG(z) < 0.0) cby1=-(cby1-2.0D0*ci*cbj1)
    IF (DIMAG(z) > 0.0) cby1=-(cby1+2.0D0*ci*cbj1)
    cbj1=-cbj1
  END IF
  cdy0=-cby1
  cdy1=cby0-1.0D0/z*cby1
END IF
70   IF (kf == 0) THEN
  zf=cby0
  zd=cdy0
ELSE IF (kf == 1) THEN
  zf=cby1
  zd=cdy1
ELSE IF (kf == 2) THEN
  zf=cdy1
  zd=-cdy1/z-(1.0D0-1.0D0/(z*z))*cby1
END IF
RETURN
END SUBROUTINE cy01


 	Program P1
 	Implicit none
	Real*8 dt, min, max, t, y(5)
c n: number of equations (the 'dimension' of the standard form)
	Integer	n
C number of component
        parameter (n=2)
C 	 y 1: pos; 2: vel;
C starting and end points
        min=0.0D0
        max=200.0D0
C time step
        dt=0.1D0
C initial position
        y(1)=0.0D0
C initial velocity
        y(2)=4.0D0
        print *, sqrt(4.0D0**2.D0+2.d0*400*max/70)
c open file to output
        Open(6, File='p1.dat')
c do n steps of Runga-Kutta algorithm
	Do t=min, max, dt
	  Call rk2(t, dt, y, n)
          Write (6,*) t, y(2)
   	enddo
c
	Close(6)
	Stop
        End
c------------------------end of main program------------------------
c
c second-order Runge-Kutta subroutine
c will update y(1) & y(2) based on n=2
	Subroutine rk2(t, dt, y, n)
	Implicit none
	Real*8 deriv, h, t, dt, y(1)
        Real*8 k1(5), k2(5), t1(5)
     	Integer i, n

     	h=dt/2.0D0
	Do i = 1,n
	   k1(i) = dt * deriv(y, i)
	   t1(i) = y(i) + 0.5D0*k1(i)
   	enddo
	Do i = 1,n
	   k2(i) = dt * deriv(t1, i)
	   y(i) = y(i) + k2(i)
   	enddo
c
	Return
	End

c function which returns the derivatives (RHS)
	Function deriv(temp, i)
C 2 function components: dx/dt = v(t),   dv/dt = -w**2*x(t) -a*v
C the second term is damping term
c  i=1, return temp(2)->y(2): vel
c  i=2, return -w**2*temp(1)-> -w^2*y(1): pos
	Implicit none
c declarations
	Real*8 deriv, temp(2), omega, alpha
	Integer i
	data omega /5.7143d0/
c   dv/dt=P/(mv)= 400/70/v=5.7143/v
c   dx/dt=v
	data alpha /0.5d0/
c
	If (i .EQ. 1) deriv=temp(2)
	If (i .EQ. 2) deriv=omega / temp(2)
	Return
	End


! --------------------------------------------------------------------------------------- !
! This file is part of Pyccel which is released under MIT License. See the LICENSE file   !
! or go to https://github.com/pyccel/pyccel/blob/master/LICENSE for full license details. !
! --------------------------------------------------------------------------------------- !

module pyc_math

use ISO_C_BINDING

implicit none

real(C_DOUBLE), parameter, private :: pi = 4.0_C_DOUBLE * DATAN(1.0_C_DOUBLE)

interface pyc_gcd
    module procedure pyc_gcd_4
    module procedure pyc_gcd_8
end interface

interface pyc_factorial
    module procedure pyc_factorial_4
    module procedure pyc_factorial_8
end interface pyc_factorial

interface pyc_lcm
    module procedure pyc_lcm_4
    module procedure pyc_lcm_8
end interface pyc_lcm

contains

! Implementation of math factorial function
pure function pyc_factorial_4(x) result(fx) ! integers with precision 4

    implicit none

    integer(C_INT32_T), value      :: x
    integer(C_INT32_T)             :: i
    integer(C_INT32_T)             :: fx

    fx = 1_C_INT32_T
    do i = 2_C_INT32_T, x
        fx = fx * i
    enddo
    return

end function pyc_factorial_4

pure function pyc_factorial_8(x) result(fx) ! integers with precision 8

    implicit none

    integer(C_INT64_T), value       :: x
    integer(C_INT64_T)              :: fx
    integer(C_INT64_T)              :: i

    fx = 1_C_INT64_T
    do i = 2_C_INT64_T, x
        fx = fx * i
    enddo

end function pyc_factorial_8

! Implementation of math gcd function
pure function pyc_gcd_4(a, b) result(gcd) ! integers with precision 4

    implicit none

    integer(C_INT32_T), value      :: a, b
    integer(C_INT32_T)             :: x, y
    integer(C_INT32_T)             :: gcd

    x = a
    y = b
    do while (y > 0)
        x = MOD(x, y)
        x = IEOR(x, y)
        y = IEOR(y, x)
        x = IEOR(x, y)
    enddo
    gcd = x
    return

end function pyc_gcd_4

pure function pyc_gcd_8(a, b) result(gcd) ! integers with precision 8

    implicit none

    integer(C_INT64_T), value       :: a, b
    integer(C_INT64_T)              :: x, y
    integer(C_INT64_T)              :: gcd

    x = a
    y = b
    do while (y > 0)
        x = MOD(x, y)
        x = IEOR(x, y)
        y = IEOR(y, x)
        x = IEOR(x, y)
    enddo
    gcd = x
    return

end function pyc_gcd_8

! Implementation of math lcm function
pure function pyc_lcm_4(a, b) result(lcm)

    implicit none

    integer(C_INT32_T), value      :: a
    integer(C_INT32_T), value      :: b
    integer(C_INT32_T)             :: lcm

    lcm = a / pyc_gcd(a, b) * b
    return

end function pyc_lcm_4

pure function pyc_lcm_8(a, b) result(lcm)

    implicit none

    integer(C_INT64_T), value      :: a
    integer(C_INT64_T), value      :: b
    integer(C_INT64_T)             :: lcm

    lcm = a / pyc_gcd(a, b) * b
    return

end function pyc_lcm_8

! Implementation of math radians function
pure function pyc_radians(deg) result(rad)

    implicit none

    real(C_DOUBLE), value     :: deg
    real(C_DOUBLE)            :: rad

    rad = deg * (pi / 180.0_C_DOUBLE)
    return

end function pyc_radians

! Implementation of math degrees function
pure function pyc_degrees(rad) result(deg)

    implicit none

    real(C_DOUBLE), value     :: rad
    real(C_DOUBLE)            :: deg

    deg = rad * (180.0_C_DOUBLE / pi)
    return

end function pyc_degrees

end module pyc_math


!------------------------------------------------------------------------------
! NASA/GSFC, Software Integration & Visualization Office, Code 610.3
!------------------------------------------------------------------------------
!
! MODULE: Module Name
!
!> @author
!> Module Author Name and Affiliation
!
! DESCRIPTION:
!> Brief description of module.
!
! REVISION HISTORY:
! DD Mmm YYYY - Initial Version
! TODO_dd_mmm_yyyy - TODO_describe_appropriate_changes - TODO_name
!------------------------------------------------------------------------------

MODULE MyMod
  IMPLICIT NONE

  Integer, Parameter :: WP = KIND(1.0D+00) !> Working precision for real variables.
  Integer  :: N  !> Number of integration intervals.
  Real(wp) :: Dx

CONTAINS

  !---------------------------------------------------------------------------
  !> @author
  !> Baudilio Tejerina - Home.
  !
  ! DESCRIPTION:
  !> Compute the integral of the function A = f(x) by the trapecium quadrature.
  !> @brief
  !> Flow method (rate of change of position) used by integrator.
  !> Compute \f$ \frac{d\lambda}{dt} , \frac{d\phi}{dt},  \frac{dz}{dt} \f$
  !
  ! REVISION HISTORY:
  ! TODO_dd_mmm_yyyy - TODO_describe_appropriate_changes - TODO_name
  !
  !> @param[in] inParam
  !> @param[out] outParam
  !> @return returnValue
  !---------------------------------------------------------------------------
  !
  REAL(KIND=WP) FUNCTION Integrate(A)
    IMPLICIT NONE
    Real(WP), Dimension(:), Pointer :: A
    REAL(WP) :: S1, S2 !> @var Var description

    S1 = Sum( A(2:N-1) )
    S2 = A(1) + A(N)
    Integrate = dx * ( S1 + S2 / 2.0 )

  END FUNCTION Integrate

end MODULE MyMod

!> Main program. Adding a new comment to alter the source.
!> Changing further.
PROGRAM MAIN
  USE MyMod
  implicit none

  Real(wp) :: xi, xf                              ! Integration limits
  REAL(WP), Dimension(:), Pointer :: A => NULL()  ! Array that will contain the data.

  ! ---
  xi= -1.0_wp
  xf=  1.0_wp

  Print '(A$)', "Enter the number of integration intervals: "
  Read *, N

  N=4  ! For testing purposes.

  Dx = (xf-xi)/(n-1) !
  Allocate(A(N))  ! Allocate space for the data array.

! Load data into the array:
  A = [1., -1., -1., 1.]

! Call the integrate function, return the value of the integral and print it
  Print '(//"Integrate Func: ", F12.5)', Integrate(A)

! Free memory used by array A. (Not necessary here, but it's a good programming practice.)
  Deallocate(A)

  Print '(T12A)', "-- the End --"
  STOP "All Done"
! CALL EXIT(0)
END PROGRAM MAIN


program P5
  implicit none
  real :: x1,x2,y1,y2,z1,z2,di
  real, external :: f

  print *,'please input the first point'
  read *,x1,y1,z1
  print *,'please input the second point'
  read *,x2,y2,z2

  call dist(x1,y1,z1,x2,y2,z2,di)
  print *, 'the distance by subroutine is ',di
  di = f(x1,y1,z1,x2,y2,z2)
  print *, 'the distance by function is ',di
end program P5

subroutine dist(x,y,z,a,b,c,d)
  implicit none
  real, intent(in) :: x,y,z,a,b,c
  real, intent(out) :: d
  d=sqrt((x-a)**2+(y-b)**2+(z-c)**2)
end subroutine dist

real function f(x,y,z,a,b,c)
  implicit none
  real, intent(in) :: x,y,z,a,b,c

  f=sqrt((x-a)**2+(y-b)**2+(z-c)**2)
end function f


subroutine apply_pde_operator(t, q, output)

! For the PDE q_t = g(q), calculates g(q).
!
! Args:
!   t: Time at which the operator is evaluated.
!   q: PDE solution at time t.
!   output: g(q), calculated here.

    implicit none

    integer :: mx, mbc, meqn
    double precision :: x_lower, dx
    common /claw_config/ mx, mbc, x_lower, dx, meqn

    double precision, intent(in) :: t
    double precision, dimension(1-mbc:mx+mbc, meqn), intent(in) :: q
    double precision, dimension(1-mbc:mx+mbc, meqn), intent(out) :: output

    double precision, dimension(2) :: lower_flux, upper_flux
    integer :: ix

    do ix = 1, mx
        call compute_flux(ix, lower_flux)
        call compute_flux(ix+1, upper_flux)
        output(ix, :) = -(upper_flux - lower_flux) / dx
    end do

    contains

    subroutine compute_flux(ix, flux)
        implicit none
        integer, intent(in) :: ix
        double precision, dimension(2), intent(out) :: flux
        double precision :: q1_face, q2_face, q2_x

        q1_face = (q(ix-1, 1) + q(ix, 1)) / 2.d0
        q2_face = (q(ix-1, 2) + q(ix, 2)) / 2.d0
        q2_x = (q(ix, 2) - q(ix-1, 2)) / dx

        flux(1) = -.5d0 * q1_face**2 * q2_x
!         flux(1) = -.5d0 * q(ix-1, 1)**2 * q2_x
        flux(2) = -q1_face * q2_face * q2_x
    end subroutine compute_flux

end subroutine apply_pde_operator


! =================================================================================================
! This file is part of the CodeVault project. The project is licensed under Apache Version 2.0.
! CodeVault is part of the EU-project PRACE-4IP (WP7.3.C).
!
! Author(s):
!   Mariusz Uchronski <mariusz.uchronski@pwr.edu.pl>
!
! This example demonstrates the use of Fortran 90 with OpenMP for matrix-matrix multiplication.
! The example is set-up to perform single precision matrix-matrix multiplication.
!
! See [http://openmp.org] for the full OpenMP documentation.
!
! =================================================================================================

program gemm_openmp

  implicit none
  integer,parameter :: seed = 86456
  integer, parameter :: n = 400
  integer, parameter :: m = 600
  integer, parameter :: k = 800
  real, allocatable :: a(:)
  real, allocatable :: b(:)
  real, allocatable :: c(:)

  allocate(a(n*m))
  allocate(b(m*k))
  allocate(c(n*k))

  call fill_random(a, n, m)
  call fill_random(b, m, k)

  call run_gemm_openmp(a, b, c, n, m, k)

  deallocate(a)
  deallocate(b)
  deallocate(c)

end program gemm_openmp

subroutine fill_random(a, n, m)

  implicit none

  integer, intent(in) :: n, m
  real, dimension(n*m), intent(inout) :: a
  integer :: i, j
  do i=1, n
    do j=1, m
      a((i-1)*m+j) = rand()
    end do
  end do

end subroutine fill_random

subroutine print_array(a, n, m)

  implicit none

  integer, intent(in) :: n, m
  real, dimension(n*m), intent(in) :: a
  integer :: i, j
  do i=1, n
    do j=1, m
      print '(F8.4,$)', a((i-1)*m+j)
    end do
    print *, ''
  end do

end subroutine print_array

subroutine run_gemm_openmp(a, b, c, n, m, k)

  integer, intent(in) :: n, m , k
  real, dimension(n*m), intent(in) :: a
  real, dimension(m*k), intent(in) :: b
  real, dimension(n*k), intent(inout) :: c
  integer :: i, j, l
  real :: summ

!$OMP PARALLEL DO DEFAULT (NONE) &
!$OMP SHARED(n,m,k,a,b,c) PRIVATE(i,j,l,summ)
  do i=1, n
    do j=1, k
      summ = 0
      do l=1, m
        summ = summ + a((i-1)*m+l) * b((l-1)*k+j)
      end do
      c((i-1)*k+j) = summ
    end do
  end do
!$OMP END PARALLEL DO

end subroutine


C PACKAGE SPLPAK         Documentation for user entries follows
C                        the general package information.
C
C LATEST REVISION        August, 1998
C
C PURPOSE                This package contains routines for fitting
C                        (least squares) a multidimensional cubic spline
C                        to arbitrarily located data.  It also contains
C                        routines for evaluating this spline (or its
C                        partial derivatives) at any point.
C
C                        Coefficient calculation is performed in
C                        subroutines SPLCC or SPLCW and evaluation is
C                        performed by functions SPLFE or SPLDE.
C
C USAGE                  Package SPLPAK contains four user entries --
C                        SPLCC, SPLCW, SPLFE, AND SPLDE.
C
C                        The user first calls SPLCC by
C
C                          CALL SPLCC (NDIM,XDATA,L1XDAT,YDATA,NDATA,
C                                      XMIN,XMAX,NODES,XTRAP,COEF,NCF,
C                                      WORK,NWRK,IERROR)
C
C                        or SPLCW by
C
C                          CALL SPLCW (NDIM,XDATA,L1XDATA,YDATA,WDATA,
C                                      NDATA,XMIN,XMAX,NODES,XTRAP,
C                                      COEF,NCF,WORK,NWRK,IERROR)
C
C                        The parameter NDATA in the call to SPLCW
C                        enables the user to weight some of the data
C                        points more heavily than others.  Both
C                        routines return a set of coefficients in the
C                        array COEF.  These coefficients are
C                        subsequently used in the computation of
C                        function values and partial derivatives.
C                        To compute values on the spline approximation
C                        the user then calls SPLFE or SPLDE any
C                        number of times in any order provided that
C                        the values of the inputs, NDIM, COEF, XMIN,
C                        XMAX, and NODES, are preserved between calls.
C
C                        SPLFE and SPLDE are called in the following way:
C
C                          F = SPLFE (NDIM,X,COEF,XMIN,XMAX,NODES,
C                                     IERROR)
C
C                        or
C
C                          F = SPLDE (NDIM,X,NDERIV,COEF,XMIN,XMAX,
C                                     NODES,IERROR)
C
C                        The routine SPLFE returns an interpolated
C                        value at the point defined by the array X.
C                        SPLDE affords the user the additional
C                        capability of calculating an interpolated
C                        value for one of several partial derivatives
C                        specified by the array NDERIV.
C
C I/O                    None, except for error messages printed by
C                        calls to CFSARR, if an error is detected.
C
C PRECISION              Single
C
C REQUIRED LIBRARY       SUPRLS, CFAERR
C FILES
C
C LANGUAGE               FORTRAN
C
C HISTORY                Developed in 1972-73 by NCAR's
C                        Scientific Computing Division.
C
C                        Cleaned up and added to the Ngmath library in
C                        1998.
C
C PORTABILITY            FORTRAN 77
C
C***********************************************************************
C
C SUBROUTINE SPLCC (NDIM,XDATA,L1XDAT,YDATA,NDATA,XMIN,XMAX,NODES,
C                   XTRAP,COEF,NCF,WORK,NWRK,IERROR)
C
C DIMENSION OF           XDATA(NDATA,L1XDAT),YDATA(NDATA),XMIN(NDIM),
C ARGUMENTS              XMAX(NDIM),NODES(NDIM),COEF(NCF),WORK(NWRK)
C
C PURPOSE                N-dimensional cubic spline coefficient
C                        calculation by least squares.
C
C USAGE                  The usage and arguments of this routine are
C                        identical to those for SPLCW except for the
C                        omission of the array of weights, WDATA.  See
C                        entry SPLCW description immediately below for a
C                        complete description.
C
C                        CALL SPLCC (NDIM,XDATA,L1XDAT,YDATA,NDATA,XMIN,
C                                    XMAX,NODES,XTRAP,COEF,NCF,WORK,
C                                    NWRK,IERROR)
C
C***********************************************************************
C
C SUBROUTINE SPLCW (NDIM,XDATA,L1XDAT,YDATA,WDATA,NDATA,XMIN,XMAX,
C                   NODES,XTRAP,COEF,NCF,WORK,NWRK,IERROR)
C
C
C DIMENSION OF           XDATA(L1XDAT,NDATA),YDATA(NDATA),WDATA(NDATA),
C ARGUMENTS              XMIN(NDIM),XMAX(NDIM),NODES(NDIM),COEF(NCF),
C                        WORK(NWRK)
C
C PURPOSE                N-dimensional cubic spline coefficient
C                        calculation by weighted least squares on
C                        arbitrarily located data.
C
C                        A grid of evenly spaced nodes in NDIM space is
C                        defined by the arguments XMIN, XMAX and NODES.
C                        A linear basis for the class of natural splines
C                        on these nodes is formed, and a set of
C                        corresponding coefficients is computed in the
C                        array COEF.  These coefficients are chosen to
C                        minimize the weighted sum of squared errors
C                        between the spline and the arbitrarily located
C                        data values described by the arguments XDATA,
C                        YDATA and NDATA.  The smoothness of the spline
C                        in data sparse areas is controlled by the
C                        argument XTRAP.
C
C NOTE                   In order to understand the arguments of this
C                        routine, one should realize that the node grid
C                        need not bear any particular relation to the
C                        data points.  In the theory of exact-fit
C                        interpolatory splines, the nodes would in fact
C                        be data locations, but in this case they serve
C                        only to define the class of splines from which
C                        the approximating function is chosen.  This
C                        node grid is a rectangular arrangement of
C                        points in NDIM space, with the restriction that
C                        along any coordinate direction the nodes are
C                        equally spaced.  The class of natural splines
C                        on this grid of nodes (NDIM-cubic splines whose
C                        2nd derivatives normal to the boundaries are 0)
C                        has as many degrees of freedom as the grid has
C                        nodes.  Thus the smoothness or flexibility of
C                        the splines is determined by the choice of the
C                        node grid.
C
C USAGE                  CALL SPLCW (NDIM,XDATA,L1XDAT,YDATA,WDATA,
C                                    NDATA,XMIN,XMAX,NODES,XTRAP,COEF,
C                                    NCF,WORK,NWRK,IERROR)
C
C                        The spline (or its derivatives) may then be
C                        evaluated by using function SPLFE (or SPLDE).
C
C ARGUMENTS
C
C ON INPUT               NDIM
C                          The dimensionality of the problem.  The
C                          spline is a function of NDIM variables or
C                          coordinates and thus a point in the
C                          independent variable space is an NDIM vector.
C                          NDIM must be in the range 1 .LE. NDIM .LE. 4.
C
C                        XDATA
C                          A collection of locations for the data
C                          values, i.e., points from the independent
C                          variable space.  This collection is a
C                          2-dimensional array whose 1st dimension
C                          indexes the NDIM coordinates of a given point
C                          and whose 2nd dimension labels the data
C                          point.  For example, the data point with
C                          label IDATA is located at the point
C                          (XDATA(1,IDATA),...,XDATA(NDIM,IDATA)) where
C                          the elements of this vector are the values of
C                          the NDIM coordinates.  The location, number
C                          and ordering of the data points is arbitrary.
C                          The dimension of XDATA is assumed to be
C                          XDATA(L1XDAT,NDATA).
C
C                        L1XDAT
C                          The length of the 1st dimension of XDATA in
C                          the calling program.  L1XDAT must be .GE.
C                          NDIM.
C
C                               NOTE:  For 1-dimensional problems L1XDAT
C                                      is usually 1.
C
C                        YDATA
C                          A collection of data values corresponding to
C                          the points in XDATA.  YDATA(IDATA) is the
C                          data value associated with the point
C                          (XDATA(1,IDATA),...,XDATA(NDIM,IDATA)) in the
C                          independent variable space.  The spline whose
C                          coefficients are computed by this routine
C                          approximates these data values in the least
C                          squares sense.  The dimension is assumed to be
C                          YDATA(NDATA).
C
C                        WDATA
C                          A collection of weights.  WDATA(IDATA) is a
C                          weight associated with the data point
C                          labelled IDATA.  It should be non-negative,
C                          but may be of any magnitude.  The weights
C                          have the effect of forcing greater or lesser
C                          accuracy at a given point as follows: this
C                          routine chooses coefficients to minimize the
C                          sum over all data points of the quantity
C
C                            (WDATA(IDATA)*(YDATA(IDATA) - spline value
C                            at XDATA(IDATA)))**2.
C
C                          Thus, if the reliability
C                          of a data point is known to be low, the
C                          corresponding weight may be made small
C                          (relative to the other weights) so that the
C                          sum over all data points is affected less by
C                          discrepencies at the unreliable point.  Data
C                          points with zero weight are completely
C                          ignored.
C
C                               NOTE:  If WDATA(1) is .LT. 0, the other
C                                      elements of WDATA are not
C                                      referenced, and all weights are
C                                      assumed to be unity.
C
C                          The dimension is assumed to be WDATA(NDATA)
C                          unless WDATA(1) .LT. 0., in which case the
C                          dimension is assumed to be 1.
C
C                        NDATA
C                          The number of data points mentioned in the
C                          above arguments.
C
C                        XMIN
C                          A vector describing the lower extreme corner
C                          of the node grid.  A set of evenly spaced
C                          nodes is formed along each coordinate axis
C                          and XMIN(IDIM) is the location of the first
C                          node along the IDIM axis.  The dimension is
C                          assumed to be XMIN(NDIM).
C
C                        XMAX
C                          A vector describing the upper extreme corner
C                          of the node grid.  A set of evenly spaced
C                          nodes is formed along each coordinate axis
C                          and XMAX(IDIM) is the location of the last
C                          node along the IDIM axis.  The dimension is
C                          assumed to be XMAX(NDIM).
C
C                        NODES
C                          A vector of integers describing the number of
C                          nodes along each axis.  NODES(IDIM) is the
C                          number of nodes (counting endpoints) along
C                          the IDIM axis and determines the flexibility
C                          of the spline in that coordinate direction.
C                          NODES(IDIM) must be .GE. 4, but may be as
C                          large as the arrays COEF and WORK allow.
C                          The dimension is assumed to be NODES(NDIM).
C
C                          NOTE:  The node grid is completely defined by
C                                 the arguments XMIN, XMAX and NODES.
C                                 The spacing of this grid in the IDIM
C                                 coordinate direction is:
C
C                                   DX(IDIM) = (XMAX(IDIM)-XMIN(IDIM)) /
C                                              (NODES(IDIM)-1).
C
C                                 A node in this grid may be indexed by
C                                 an NDIM vector of integers
C                                 (IN(1),...,IN(NDIM)) where
C                                 1 .LE. IN(IDIM) .LE. NODES(IDIM).
C                                 The location of such a node may be
C                                 represented by an NDIM vector
C                                 (X(1),...,X(NDIM)) where
C                                 X(IDIM) = XMIN(IDIM) + (IN(IDIM)-1) *
C                                                         DX(IDIM).
C
C                        XTRAP
C                          A parameter to control extrapolation to data
C                          sparse areas.  The region described by XMIN
C                          and XMAX is divided into rectangles, the
C                          number of which is determined by NODES, and
C                          any rectangle containing a disproportionately
C                          small number of data points is considered to
C                          be data sparse (rectangle is used here to
C                          mean NDIM-dimensional rectangle).  If XTRAP
C                          is nonzero the least squares problem is
C                          augmented with derivative constraints in the
C                          data sparse areas to prevent the matrix from
C                          becoming poorly conditioned.  XTRAP serves as
C                          a weight for these constraints, and thus may
C                          be used to control smoothness in data sparse
C                          areas.  Experience indicates that unity is a
C                          good first guess for this parameter.
C
C                               NOTE:  If XTRAP is zero, substantial
C                                      portions of the routine will be
C                                      skipped, but a singular matrix
C                                      can result if large portions of
C                                      the region are without data.
C
C                        NCF
C                          The length of the array COEF in the calling
C                          program.  If NCF is .LT.
C                          NODES(1)*...*NODES(NDIM), a fatal error is
C                          diagnosed.
C
C                        WORK
C                          A workspace array for solving the least
C                          squares matrix generated by this routine.
C                          Its required size is a function of the total
C                          number of nodes in the node grid.  This
C                          total, NCOL = NODES(1)*...*NODES(NDIM), is
C                          also the number of columns in the least
C                          squares matrix.  The length of the array WORK
C                          must equal or exceed NCOL*(NCOL+1).
C
C                        NWRK
C                          The length of the array WORK in the calling
C                          program.  If
C                          NCOL = NODES(1)*...*NODES(NDIM) is the total
C                          number of nodes, then a fatal error is
C                          diagnosed if NWRK is less than
C                          NCOL*(NCOL+1).
C
C ON OUTPUT              COEF
C                          The array of coefficients computed by this
C                          routine.  Each coefficient corresponds to a
C                          particular basis function which in turn
C                          corresponds to a node in the node grid.  This
C                          correspondence between the node grid and the
C                          array COEF is as if COEF were an
C                          NDIM-dimensional Fortran array with
C                          dimensions NODES(1),...,NODES(NDIM), i.e., to
C                          store the array linearly, the leftmost
C                          indices are incremented most frequently.
C                          Hence the length of the COEF array must equal
C                          or exceed the total number of nodes, which is
C                          NODES(1)*...*NODES(NDIM).  The computed array
C                          COEF may be used with function SPLFE
C                          (or SPLDE) to evaluate the spline (or its
C                          derivatives) at an arbitrary point in NDIM
C                          space.  The dimension is assumed to be COEF(NCF).
C
C                        WORK
C                          The workspace containing intermediate
C                          calculations.  It need not be saved.
C
C                        IERROR
C                          An error flag with the following meanings:
C                              0  No error.
C                            101  NDIM is .LT. 1 or is .GT. 4.
C                            102  NODES(IDIM) is .LT. 4 fOR some IDIM.
C                            103  XMIN(IDIM) = XMAX(IDIM) for some IDIM.
C                            104  NCF (size of COEF) is
C                                 .LT. NODES(1)*...*NODES(NDIM).
C                            105  NDATA is .LT. 1.
C                            106  NWRK (size of WORK) is too small.
C                            107  SUPRLS failure (usually insufficient
C                                 data) -- ordinarily occurs only if
C                                 XTRAP is zero or WDATA contains all
C                                 zeros.
C
C ALGORITHM              An overdetermined system of linear equations
C                        is formed -- one equation for each data point
C                        plus equations for derivative constraints.
C                        This system is solved using subroutine SUPRLS.
C
C ACCURACY               If there is exactly one data point in the
C                        near vicinity of each node and no extra data,
C                        the resulting spline will agree with the
C                        data values to machine accuracy.  However, if
C                        the problem is overdetermined or the sparse
C                        data option is utilized, the accuracy is hard
C                        to predict.  Basically, smooth functions
C                        require fewer nodes than rough ones for the
C                        same accuracy.
C
C TIMING                 The execution time is roughly proportional
C                        to NDATA*NCOF**2 where NCOF = NODES(1)*...*
C                        NODES(NDIM).
C
C***********************************************************************
C
      SUBROUTINE SPLCC (NDIM,XDATA,L1XDAT,YDATA,NDATA,XMIN,XMAX,NODES,
     1                  XTRAP,COEF,NCF,WORK,NWRK,IERROR)
      DIMENSION       XDATA(L1XDAT,NDATA)    ,YDATA(NDATA)           ,
     1                XMIN(NDIM) ,XMAX(NDIM) ,NODES(NDIM),COEF(NCF)  ,
     2                WORK(NWRK)
      DIMENSION       W(1)
      SAVE
C
      W(1) = -1.
      CALL SPLCW (NDIM,XDATA,L1XDAT,YDATA,W,NDATA,XMIN,XMAX,NODES,
     +            XTRAP,COEF,NCF,WORK,NWRK,IERROR)
C
      RETURN
      END


!##############################################################################
! PROGRAM distributions
!
! ## Probability density functions and cumulative distributions
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program distributions

    use toolbox

    implicit none
    integer, parameter :: NN = 1000
    real*8 :: z(0:NN), dens(0:NN), dist(0:NN)
    real*8 :: a, b, mu, sigma, alpha, beta, p, q
    integer :: ii, n

    ! uniform distribution
    a = -1d0
    b = 1d0
    call grid_Cons_Equi(z, a-0.5d0, b+0.5d0)
    do ii = 0, NN
        dens(ii) = uniformPDF(z(ii), a, b)
        dist(ii) = uniformCDF(z(ii), a, b)
    enddo

    call plot(z, dens, legend="Density")
    call plot(z, dist, legend="Distribution")
    call execplot(title="Uniform Distribution")

    ! normal distribution
    mu = 1d0
    sigma = 0.25d0

    call grid_Cons_Equi(z, mu-4d0*sqrt(sigma), mu+4d0*sqrt(sigma))
    do ii = 0, NN
        dens(ii) = normalPDF(z(ii), mu, sigma)
        dist(ii) = normalCDF(z(ii), mu, sigma)
    enddo

    call plot(z, dens, legend="Density")
    call plot(z, dist, legend="Distribution")
    call execplot(title="Normal Distribution")

    ! log-normal distribution
    mu = 1d0
    sigma = 0.25d0

    call grid_Cons_Equi(z, 0d0, mu+5d0*sqrt(sigma))
    do ii = 0, NN
        dens(ii) = log_normalPDF(z(ii), mu, sigma)
        dist(ii) = log_normalCDF(z(ii), mu, sigma)
    enddo

    call plot(z, dens, legend="Density")
    call plot(z, dist, legend="Distribution")
    call execplot(title="Log-Normal Distribution")

    ! Gamma distribution
    alpha = 2d0
    beta = 1.25d0

    call grid_Cons_Equi(z, 0d0, 5d0)
    do ii = 0, NN
        dens(ii) = GammaPDF(z(ii), alpha, beta)
        dist(ii) = GammaCDF(z(ii), alpha, beta)
    enddo

    call plot(z, dens, legend="Density")
    call plot(z, dist, legend="Distribution")
    call execplot(title="Gamma Distribution")

    ! beta distribution
    p = 2d0
    q = 5d0

    call grid_Cons_Equi(z, -0.2d0, 1.2d0)
    do ii = 0, NN
        dens(ii) = betaPDF(z(ii), p, q)
        dist(ii) = betaCDF(z(ii), p, q)
    enddo

    call plot(z, dens, legend="Density")
    call plot(z, dist, legend="Distribution")
    call execplot(title="beta Distribution")

    ! bernoulli distribution
    p = 0.25d0
    do ii = 0, 1
        z(ii) = dble(ii)
        dens(ii) = bernoulliPDF(ii, p)
        dist(ii) = bernoulliCDF(ii, p)
    enddo

    call plot(z(0:1), dens(0:1), legend="Probabilities", marker=3, markersize=1.5d0, noline=.true.)
    call plot(z(0:1), dist(0:1), legend="Distribution", marker=3, markersize=1.5d0, noline=.true.)
    call execplot(title="Bernoulli Distribution")

    ! binomial distribution
    p = 0.25d0
    n = 12
    do ii = 0, n
        z(ii) = dble(ii)
        dens(ii) = binomialPDF(ii, n, p)
        dist(ii) = binomialCDF(ii, n, p)
    enddo

    call plot(z(0:n), dens(0:n), legend="Probabilities", marker=3, markersize=1.5d0, noline=.true.)
    call plot(z(0:n), dist(0:n), legend="Distribution", marker=3, markersize=1.5d0, noline=.true.)
    call execplot(title="Binomial Distribution")

end program


      program problem1
      integer sum, counter, MAX
      parameter (MAX = 1000)

C     Find the sum of all the multiples of 3 or 5 below 1000

      sum = 0

C     Sum all multiples of 3
      do 10 counter = 3, MAX-1, 3
         sum = sum + counter
 10   continue

C     Sum all multiples of 5
      do 20 counter = 5, MAX-1, 5
         sum = sum + counter
 20   continue

C     Subtract multiples of 15 to avoid double counting
      do 30 counter = 15, MAX-1, 15
         sum = sum - counter
 30   continue

      write (*, *) 'The sum is ', sum

      stop
      end


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2020 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.
!
      subroutine ts_calc(xflow,Tt,pt,kappa,r,A,Ts,icase)
!
!     Calculation of the static temperature Ts from the total
!     temperature Tt, the total pressure Pt and the mass flow xflow
!
!     Use of the General Gas Equation
!
!     this subroutine solves the implicit equation
!     xflow*dsqrt(Tt)/(A*Pt)-C*(Tt/Ts)**expon*(Tt/Ts-1)**0.5d0=0.d0
!
!          expon=-0.5d0*(kappa+1.d0)/(kappa-1.d0)
!          C=dsqrt(2.d0/r*kappa/(kappa-1.d0))
!
!     xflow is the mass flow for 360 degrees, sign is irrelevant
!     for this routine
!
!     author: Yannick Muller
!
      implicit none
!
      integer icase,i,rf
!
      real*8 xflow,Tt,pt,Ts,kappa,r,f,df,A,expon,Ts_old,C,TtzTs,
     &     deltaTs,TtzTs_crit, Qred_crit,Qred,h1,h2,h3,Ts_min,
     &     Ts_max,f_min,f_max
!
!
!
!     regula falsi flag (rf=0 newton-raphson is active,
!     rf=1 regula falsi is active)
      rf=0
!
      expon=-0.5d0*(kappa+1.d0)/(kappa-1.d0)
!
      C=dsqrt(2.d0/r*kappa/(kappa-1.d0))
!
!     f=xflow*dsqrt(Tt)/(A*pt)-C*(Tt/Ts)**expon*(Tt/Ts-1)**0.5d0
!
!     df=-C*Tt/Ts**expon*(expon/Ts*(Tt/Ts-1)**0.5d0
!     &     -0.5d0*Tt/Ts/Ts*(Tt/Ts-1.d0)**(-0.5d0))
!
      Ts_old=Tt
!
      if(dabs(xflow).le.1d-10) then
         Ts=Tt
         return
      endif
!
      Qred=abs(xflow)*dsqrt(Tt)/(A*pt)
!
!     optimised estimate of T static
!
      Ts=Tt/(1.d0+(Qred**2.d0/C**2.d0))
!
!     adiabatic
!
      if(icase.eq.0) then
         TtzTs_crit=(kappa+1.d0)/2.d0
!
!     isothermal
!
      else
         TtzTs_crit=(1d0+(kappa-1.d0)/(2.d0*kappa))
      endif
!
      Qred_crit=C*(TtzTs_crit)**expon*(Ttzts_crit-1.d0)**0.5d0
!
      if(Qred.ge.Qred_crit) then
         Ts=Tt/TtzTs_crit
         return
      endif
!
      i=0
!
!     start of the Newton-Raphson-Procedure to solve the nonlinear
!     equation
!
      do
!
         if((Ts.ge.Tt).or.(Ts.le.Tt/TtzTs_crit))then
!
!           to avoid estimated values, in that case the slower
!           regula falsi is used
!
            rf=1
            exit
         endif
!
         i=i+1
         Ttzts=Tt/Ts
         h1=Ttzts-1.d0
         h2=dsqrt(h1)
         h3=Ttzts**expon
!
         f=C*h2*h3
!
         df=f*(expon+0.5d0*Ttzts/h1)/Ts
!
         f=Qred-f
         deltaTs=-f/df
!
         Ts=Ts+deltaTs
!
         if((((dabs(Ts-Ts_old)/ts_old).le.1.d-8))
     &        .or.((dabs(Ts-Ts_old)).le.1.d-10)) then
            exit
         else if(i.gt.20) then
            rf=1
            exit
         endif
         Ts_old=Ts
      enddo
!
      if(rf.eq.0)then
         return
      endif
!
!     regula falsi procedure
!
      i=1
      Ts_min=Tt/TtzTs_crit
      Ts_max=Tt
      Ts_old=Tt+1.d0
!
      f_min=Qred-C*dsqrt(Tt/Ts_min-1)*(Tt/Ts_min)**expon
      f_max=Qred
!
      do
         i=i+1
         Ts=(Ts_min+Ts_max)/2.d0
         f=Qred-C*dsqrt(Tt/Ts-1)*(Tt/Ts)**expon
!
         if((((dabs(Ts-Ts_old)/Ts_old).le.1.d-8))
     &        .or.((dabs(Ts-Ts_old)).le.1.d-10)) then
            exit
         endif
!
         if(i.gt.10000000)then
            write(*,*)'*ERROR in ts_calc.f'
            write(*,*)'       max. iteration number exceeded'
           call exit(201)
         endif
!
         if(f_min*f.le.0.d0)then
            Ts_max=Ts
            f_max=f
         else
            Ts_min=Ts
            f_min=f
         endif
!
         Ts_old=Ts
!
      enddo
!
      return
      end


!> Various handy routines useful for writing unit tests.
module grasptest_testing
    use, intrinsic :: iso_fortran_env, only: real64, dp => real64
    implicit none

    interface test_isequal
        module procedure test_isequal_real64, test_isequal_logical
    end interface test_isequal

contains

    !> Calculate the relative difference of `a` and `b`.
    !!
    !! The relative difference is defined as:
    !!
    !! \f[
    !!   \frac{|a-b|}{\max(|a|, |b|)}
    !! \f]
    !!
    !! @param a,b Input values.
    !! @returns The relative difference of `a` and `b`.
    function reldiff(a, b)
        real(real64), intent(in) :: a, b
        real(real64) :: reldiff
        reldiff = abs(a-b) / max(abs(a), abs(b))
    end function reldiff

    !> Checks if the difference of `a` and `b` are within the tolerance relative
    !! to \f$\max(|a|,|b|)\f$.
    !!
    !! @param a,b Values to be checked.
    !! @param relative_tolerance Relative tolerance \f$\sigma\f$.
    !! @returns Whether \f$|a-b| / \max(|a|,|b|) < \sigma\f$.
    function within_tolerance(a, b, relative_tolerance)

        real(real64), intent(in) :: a, b, relative_tolerance
        logical :: within_tolerance
        real(real64) :: relative_difference

        relative_difference = abs(a-b) / max(abs(a), abs(b))
        if (relative_difference < relative_tolerance) then
            within_tolerance = .true.
        else
            within_tolerance = .false.
        endif
    end function within_tolerance

    !> Tests if two floating point values are the same withing the specified
    !! relative tolerance.
    !!
    !! Specifically, it tests that
    !!
    !! \f[
    !!     \frac{|a-b|}{\max(|a|, |b|)} < \sigma
    !! \f]
    !!
    !! where \f$\sigma\f$ is the specified relative tolerance.
    !!
    !! If the test fails, `test_passed` gets set to `.false.`, but the value is
    !! unchanged if the tests pass. This allows for the pattern where the test
    !! function is called multiple times before checking if any of the tests
    !! failed:
    !!
    !! ```
    !! call test_equality(success, "T1", a1, b1, rtol)
    !! call test_equality(success, "T2", a2, b2, rtol)
    !! if(.not.success) then
    !!     print *, "Test failures occurred."
    !! endif
    !! ```
    !!
    !! On failure, a message gets printed into the standard output that a test
    !! failed, which also includes the `which` string, allowing for the failed
    !! test to be identified easily.
    !!
    !! @param test_passed Gets set to `.false.` if the test fails, and is left
    !!   unchanged otherwise.
    !! @param which A string that identifies the test.
    !! @param a,b Values to be compared.
    !! @param relative_tolerance The relative tolerance \f$\sigma\f$.
    subroutine test_isequal_real64(test_passed, which, a, b, relative_tolerance)

        logical, intent(inout) :: test_passed
        character(*), intent(in) :: which
        real(real64), intent(in) :: a, b, relative_tolerance
        real(real64) :: relative_difference

        if (.not.within_tolerance(a, b, relative_tolerance)) then
            relative_difference = abs(a-b) / max(abs(a), abs(b))
            print '("  Test failed: ",a," not within tolerance. Rel.diff: ",es12.5,", tol: ",es12.5)', &
                which, relative_difference, relative_tolerance
            test_passed = .false.
        endif
    end subroutine test_isequal_real64

    !> Tests if two logical values are equal.
    subroutine test_isequal_logical(test_passed, which, a, b)
        logical, intent(inout) :: test_passed
        character(*), intent(in) :: which
        logical, intent(in) :: a, b

        if (.not.(a.eqv.b)) then
            print '("  Test failed: logical values differ for ",a," (a=",L1,", b=",L1,")")', &
                which, a, b
            test_passed = .false.
        endif
    end subroutine test_isequal_logical

end module grasptest_testing


program nilakanthaPi
implicit none
integer, parameter :: dp=kind(0.d0)
real(dp) :: p, c, s
integer :: v
p = 3_dp
s = 1_dp
c = 2_dp
do v = 1, 1000000
  p = p+(s*(4_dp/(c*(2_dp+(c*(c+3_dp))))))
  s = -1_dp*s
  c = c+2_dp
end do
print *, "pi =", p
end program nilakanthaPi


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     THIS PROGRAM ILLUSTRATES THE USE OF SUBROUTINE HSTCSP TO SOLVE
C     THE EQUATION
C
C               (1/R**2)(D/DR)(R**2(DU/DR)) +
C
C     (1/R**2*SIN(THETA))(D/DTHETA)(SIN(THETA)(DU/DTHETA))
C
C                     = 12*(R*COS(THETA))**2
C
C     ON THE RECTANGLE 0 .LT. THETA .LT. PI , 0 .LT. R .LT. 1
C     WITH THE BOUNDARY CONDITIONS
C
C     U(THETA,1) = COS(THETA)**4 , O .LE. THETA .LE. PI
C
C     AND THE SOLUTION UNSPECIFIED ON THE REMAINING BOUNDARIES.
C     WE WILL USE 45 UNKNOWNS IN THE THETA-INTERVAL AND 15 UNKNOWNS
C     IN THE R-INTERVAL.
C
      DIMENSION       F(47,16)   ,BDD(45)    ,W(615)     ,THETA(45)  ,
     1                R(15)      ,COST(45)
C
C     NOTE THAT FROM DIMENSION STATEMENT WE GET THAT IDIMF = 47  AND
C     THAT W IS DIMENSIONED ACCORDING TO THE STATEMENT IN THE
C     DESCRIPTION OF W.
C
      IDIMF = 47
      A = 0.
      B = PIMACH(DUM)
C
C     NOTE THAT B IS SET TO PI USING THE FUNCTION PIMACH AS REQUIRED.
C
      M = 45
      MBDCND = 9
      DT = (B-A)/FLOAT(M)
C
C     DEFINE GRID POINTS THETA(I) AND COS(THETA(I))
C
      DO 101 I=1,M
         THETA(I) = A+(FLOAT(I)-0.5)*DT
         COST(I) = COS(THETA(I))
  101 CONTINUE
      C = 0.
      D = 1.
      N = 15
      NBDCND = 5
      DR = (D-C)/FLOAT(N)
C
C     DEFINE GRID POINTS R(J)
C
      DO 102 J=1,N
         R(J) = C+(FLOAT(J)-0.5)*DR
  102 CONTINUE
C
C     DEFINE BOUNDARY ARRAY BDD.  BDA, BDB, AND BDC ARE DUMMY
C     VARIABLES IN THIS EXAMPLE.
C
      DO 103 I=1,M
         BDD(I) = COST(I)**4
  103 CONTINUE
      ELMBDA = 0.
C
C     DEFINE RIGHT SIDE F
C
      DO 105 I=1,M
         DO 104 J=1,N
            F(I,J) = 12.*(R(J)*COST(I))**2
  104    CONTINUE
  105 CONTINUE
      INTL = 0
      CALL HSTCSP (INTL,A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,
     1             ELMBDA,F,IDIMF,PERTRB,IERROR,W)
C
C     COMPUTE DISCRETIZATION ERROR.  THE EXACT SOLUTION IS
C
C     U(THETA,R) = (R*COS(THETA))**4
C
      ERR = 0.
      DO 107 I=1,M
         DO 106 J=1,N
            Z = ABS(F(I,J)-(R(J)*COST(I))**4)
            IF (Z .GT. ERR) ERR = Z
  106    CONTINUE
  107 CONTINUE
      PRINT 1001 , IERROR,ERR,W(1)
      STOP IERROR
C
 1001 FORMAT (1H1,20X,25HSUBROUTINE HSTCSP EXAMPLE///
     1        10X,46HTHE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS//
     2        32X,10HIERROR = 0/
     3        18X,34HDISCRETIZATION ERROR = 5.58432E-03/
     4        12X,32HREQUIRED LENGTH OF W ARRAY = 583//
     5        10X,32HTHE OUTPUT FROM YOUR COMPUTER IS//
     6        32X,8HIERROR =,I2/18X,22HDISCRETIZATION ERROR =,E12.5/
     7        12X,28HREQUIRED LENGTH OF W ARRAY =,F4.0)
C
      END


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED 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
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Makes Gauss-Legendre-Lobatto nodes.
!! @author Ilario Mazzieri
!> @date September, 2013
!> @version 1.0
!> @param[in] np number of points
!> @param[out] ct  LGL nodes

      subroutine MAKE_LGL_NODES(np,ct)

      implicit real*8 (a-h,o-z)

      integer*4 :: np

      real*8, dimension(np) :: ct

      parameter (nstep=1000,acc=1.d-15)

      n=np-1
      ct(1)=-1.d0
      ct(np)=1.d0
      n2=idint(0.5d0*np)
      dx=2.d0/dfloat(nstep)
      x=-1.d0
      iroot=1
      call GET_LEGENDRE_VALUE (p2,a1,p1,p1der,n,x)
      do while (iroot.lt.n2)
        x=x+dx
        call GET_LEGENDRE_VALUE (p2,a2,p1,p1der,n,x)
        if (dabs(a2).le.acc) then
          iroot=iroot+1
          ct(iroot)=a2
        else
          aa=a1*a2
          if (aa.lt.0.d0) then
            iroot=iroot+1
            ct(iroot)=FIND_ROOT_POL(x-dx,x,acc,n)
          endif
        endif
        a1=a2
      enddo

      n_filt=2*n2
      if (n_filt.ne.np) then         ! np odd
        ct(n2+1)=0.d0
        do i=1,n2-1
          ct(np-i)=-ct(i+1)
        enddo
      else                           ! np even
        do i=1,n2-1
          ct(np-i)=-ct(i+1)
        enddo
      endif

      return

      end subroutine MAKE_LGL_NODES


PROGRAM ScalarWaveTest

  USE KindModule, ONLY: &
    DP, One, Two, Zero, TwoPi
  USE ProgramHeaderModule, ONLY: &
    iX_B0, iX_B1, iX_E0, iX_E1, &
    nDimsX
  USE ReferenceElementModuleX, ONLY: &
    InitializeReferenceElementX, &
    FinalizeReferenceElementx
  USE ReferenceElementModuleX_Lagrange, ONLY: &
    InitializeReferenceElementX_Lagrange, &
    FinalizeReferenceElementX_Lagrange
  USE ScalarWave_ProgramInitializationModule, ONLY: &
    InitializeProgram, &
    FinalizeProgram
  USE InitializationModule, ONLY: &
    InitializeFields
  USE ScalarWave_InputOutputModuleHDF, ONLY: &
    WriteFieldsHDF, &
    ReadFieldsHDF
  USE TimeSteppingModule_SSPRK, ONLY: &
    InitializeScalarWave_SSPRK, &
    FinalizeScalarWave_SSPRK, &
    UpdateScalarWave_SSPRK
  USE ScalarFieldsModule, ONLY : &
    uSF, &
    ComputeTimeStep_ScalarWave
  USE ScalarWave_dgDiscretizationModule, Only : &
    ComputeIncrement_ScalarWave_DG_Explicit

  IMPLICIT NONE

  LOGICAL  :: wrt
  INTEGER  :: iCycle, nNodes, nWrites
  REAL(DP) :: t, dt, t_end, dt_wrt, t_wrt

  t = 0.0_DP
  t_end = TwoPi
  dt_wrt = 1.0d-2 * t_end

  nNodes = 2

  CALL InitializeProgram &
         ( ProgramName_Option = 'SpacetimeTest', &
           nX_Option = [ 2048, 1, 1 ], swX_Option = [ 1, 0, 0 ], &
           bcX_Option = [ 1, 0, 0 ], xL_Option = [ Zero, Zero, Zero ], &
           xR_Option = [ TwoPi, One, One ], nNodes_Option = 3 )

  CALL InitializeReferenceElementX

  CALL InitializeReferenceElementX_Lagrange

  Call InitializeFields

  CALL WriteFieldsHDF( 0.0_DP, WriteSF_Option=.true.)

  nWrites = 1

  CALL InitializeScalarWave_SSPRK( nStages = 3 )

  t_wrt = t + dt_wrt
  wrt   = .FALSE.

  iCycle = 0
  DO WHILE ( t < t_end )

    iCycle = iCycle + 1

    CALL ComputeTimeStep_ScalarWave &
           ( iX_B0, iX_E0, iX_B1, iX_E1, uSF, &
             CFL = 0.5_DP / (nDimsX * ( Two * DBLE ( nNodes ) - One ) ), &
             Timestep = dt )

    IF( t + dt > t_end )THEN

      dt = t_end - t

    END IF

    IF( t + dt > t_wrt )THEN

      dt    = t_wrt - t
      t_wrt = t_wrt + dt_wrt
      wrt   = .TRUE.

    END IF

    CALL UpdateScalarWave_SSPRK &
           ( t, dt, uSF, ComputeIncrement_ScalarWave_DG_Explicit )

    t = t + dt

    IF( wrt )THEN

      CALL WriteFieldsHDF &
             ( t , WriteSF_Option = .TRUE. )

      wrt = .FALSE.

      nWrites = nWrites + 1
    END IF

  END DO

  CALL WriteFieldsHDF &
         ( t, WriteSF_Option = .TRUE. )

  WRITE(*,*)
  WRITE(*,'(A6,A,I6.6,A)') &
    '', 'Finished ', iCycle, ' Cycles.'
  WRITE(*,*)
  WRITE(*,'(A6,A,I6.6,A)') &
    '', 'Wrote ', nWrites, ' Files.'

  CALL FinalizeScalarWave_SSPRK

  CALL FinalizeReferenceElementX_Lagrange

  CALL FinalizeReferenceElementX

  CALL FinalizeProgram

END PROGRAM ScalarWaveTest


program cold_front
  ! This program calculates temperature due to cold front
  ! passage for different times using an external function.
  ! Listing 3.3 in the book.
  implicit none

  integer :: n
  real :: nhours

  do n = 6, 48, 6
    nhours = real(n)
    print *, 'Temparature after ', nhours, ' hours is ', &
      cold_front_temperature(12., 24., 20., 960., nhours), &
      ' degrees.'
  end do

contains

  real function cold_front_temperature(temp1, temp2, c, dx, dt) result(r)
    ! Returns the temperature after dt hours, given initial
    ! temperatures at origin (temp1) and destination (temp2),
    ! front speed (c), and distance between the two locations (dx).
    real, intent(in) :: temp1, temp2, c, dx, dt
    r = temp2 - c * (temp2 - temp1) / dx * dt
  end function cold_front_temperature

end program cold_front


!!!!!      subroutine matrixmult(A,B,C,rowsleft,columnsleft,columnsright)
!!!!!      integer rowsleft, columnsleft,columnsright
!!!!!      real*8 A(rowsleft,columnsleft), B(columnsleft,columnsright)
!!!!!      real*8 C(rowsleft,columnsright)
!!!!!
!!!!!
!!!!!      do i=1,rowsleft
!!!!!      do j=1,columnsright
!!!!!      C(i,j)=0.
!!!!!      enddo
!!!!!      enddo
!!!!!      do i = 1,rowsleft
!!!!!      do j = 1,columnsright
!!!!!          do k = 1, columnsleft
!!!!!
!!!!!                C(i,j)  = C(i,j) + A(i,k)*B(k,j)
!!!!!             enddo
!!!!!           enddo
!!!!!         enddo
!!!!!         return
!!!!!         end