      subroutine      DWATAN (N5,U5,Y5)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 2001-06-18 DWCOMP Krogh   Replaced ". and." with " .and."
C>> 1996-04-15 DWCOMP Krogh   Changed single common block name to SWCOM.
C>> 1995-11-21 DWCOMP Krogh   Removed multiple entries for C conversion.
C>> 1994-11-11 DWCOMP Krogh   Declared all vars.
C>> 1994-10-31 DWCOMP Krogh  Changes to use M77CON
C>> 1987-12-07 DWCOMP Lawson  Initial code.
c--D replaces "?": ?WCOMP,?WATAN,?WASIN,?WACOS,?WATN2,?WSUM,?WDIF,
c--&   ?WSQRT,?WEXP,?WSIN,?WCOS,?WTAN,?WSINH,?WCOSH,?WTANH,?WSET,?WSUM1,
c--&   ?WDIF1,?WPRO1,?WQUO1,?WLOG,?WPWRI,?WCHN,?WPRO,?WQUO,?PASCL,
c--&   ?WRCHN,?WACSI,?WCOM
c
C     File DWCOMP [- Wengert derivative COMPutation]
c     The file DWCOMP contains a set of program units to perform
c     computation on (N+1)-tuples representing the value of a quantity
c     and its first N derivatives with respect to a single variable.
c     In the comments we use T as the name of the ultimate independent
c     variable.
c          The parameter NMAX must be set in program units
c                   DWATAN, DWSUM, and DWPRO
c     to establish the largest order of derivative the package
c     will be able to handle.
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c     C. L. Lawson, JPL, 1971.
C     References:
c     1.   Wengert, R. E., A simple automatic derivative evaluation
c          program, Comm. ACM, 1, Aug 1964, 463-464.
c     2.   C. L. Lawson, Computing Derivatives using W-arithmetic and
c          U-arithmetic., JPL Appl Math TM 289, Sept 1971.
c     Revised by CLL for Fortran 77 in Jan 1987.  Deleted subr WSTART.
c     Put a first time flag in WPRO.  Now user does not need to make
c     any initialization call.
c     9/18/87, CLL. Added new entry names DWASIN & DWACOS.
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C     NMAX        Setting NMAX in the parameter statement determines
c           the highest order derivative this program unit will be able
c           to handle.  The following arrays have dimensions depending
c           on NMAX:  S1(), S2(), S3(), S4(), C()
c
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c                         ERROR HANDLING
c
c     All detected error conditions are essentially fatal for the
c     requested operation.  We do not stop; rather, we issue an error
c     message and return.  By use of the the MATH77 library subroutine,
c     ERMSET, the user can change the error processing action to cause a
c     STOP following the error message.
c
c     Error  Called
c      No.    name   Explanation
c
c       1    DWASIN  Infinite deriv when arg = -1 or +1
c       1    DWACOS  Infinite deriv when arg = -1 or +1
c       2    DWSQRT  Infinite deriv when arg = 0
c       3    DWQUO1  Zero divisor
c       4    DWPWRI  U**M is infinite when U = 0 and M < 0
c       5    DWPRO   Require dimension NMAX .ge. NDERIV
c       6    DWQUO   Require dimension NMAX .ge. NDERIV
c       7    DWQUO   Zero divisor
c       8    DPASCL  Require N .ge. 0
c       9    DWRCHN  Require U(2) .ne. 0.
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c               PROGRAM UNITS, entry NAMES, and calls
c
c     All of these subroutine and entry names may be called directly by
c     a user, however, it is expected that DWCHN, DWRCHN, and DPASCL
c     would only be used to augment the package with new functions.
c
C     Subroutine names:                       Calls to:
c
c     subroutine DWATAN  (N5,U5,Y5)           DWPWRI,DWCHN
c     subroutine DWASIN (N16,U16,Y16)         DWACSI
c     subroutine DWACOS (N16,U16,Y16)         DWACSI
c     subroutine DWACSI (N16,U16,Y16,ACOSIN)  DWSQRT,DWPWRI,DWPRO1,DWCHN
c     subroutine DWATN2 (N9,Y9,X9,A9)      DWSUM,DWDIF,DWPRO,DWQUO,DWCHN
c
c     subroutine DWSUM  (NDERIV,U,V,W)        None
c     subroutine DWDIF  (N2,U2,V2,W2)         None
c     subroutine DWSQRT (N15,U15,Y15)         DWCHN
c     subroutine DWEXP  (N4,U4,Y4)            DWCHN
c     subroutine DWSIN  (N7,U7,Y7)            DWCHN
c     subroutine DWCOS  (N7,U7,Y7)            DWCHN
c     subroutine DWTAN  (N7,U7,Y7)            DWCHN
c     subroutine DWSINH (N7,U7,Y7)            DWCHN
c     subroutine DWCOSH (N7,U7,Y7)            DWCHN
c     subroutine DWTANH (N7,U7,Y7)            DWCHN, DWPRO, DWQUO
c     subroutine DWSET  (N10,UVAL,UDER,U10)   None
c     subroutine DWSUM1 (N11,C11,U11,Y11)     None
c     subroutine DWDIF1 (N12,C12,U12,Y12)     None
c     subroutine DWPRO1 (N13,C13,U13,Y13)     None
c     subroutine DWQUO1 (N14,C14,U14,Y14)     DWQUO
c
c     subroutine DWLOG  (NDERIV,U,Y)          DWCHN
c     subroutine DWPWRI (NDERIV,MPWR,U,Y)     DWCHN
c
c     subroutine DWCHN  (NDERIV,U,F)          DWPRO
c
c     subroutine DWPRO  (NDERIV,U,V,W)        DPASCL
c     subroutine DWQUO  (NDERIV,U,V,W)        DPASCL
c
c     subroutine DPASCL (N   ,C)              None
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c                   Dependencies between program units
c
c     The progran units are DWATAN,DWSUM,DWLOG,DWCHN,DWPRO,DPASCL
c     DWATAN has calls into        DWSUM,DWLOG,DWCHN,DWPRO
c     DWSUM has calls into               DWLOG,DWCHN,DWPRO
c     DWLOG has calls into                     DWCHN
c     DWCHN has calls into                           DWPRO
c     DWPRO has calls into                                 DPASCL
c     DPASCL has no calls
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c
      integer N5
      double precision U5(*),Y5(*)
      integer NMAX, NMAXP1
      parameter (NMAX=10, NMAXP1=NMAX+1)
      integer I, NS
      double precision S1(NMAXP1)
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C     COMPUTE..              Y5=ATAN(U5)    and derivs w.r.t. T
C
      Y5(1)= ATAN (U5(1))
      IF(N5 .eq. 0) return
C
C     deriv of Y w.r.t. U IS  1./(1. + U**2)
C     START BY CONSTRUCTING 1.+U**2 AND ITS derivs IN S1().
C
      S1(1)=1.0D0 + U5(1)**2
      NS=N5-1
      IF(NS .eq. 0) go to 52
      S1(2)= U5(1)+U5(1)
      IF(NS .eq. 1) go to 52
      S1(3)= 2.0D0
      IF(NS .eq. 2) go to 52
          DO 50 I=3,NS
   50     S1(I+1) = 0.0D0
C
C     NOW S1() = 1.+U**2 and derivs w.r.t. U .
C     COMPUTE 1./S1 and derivs w.r.t. U.  STORE RESULT STARTING IN Y(2)
C
   52 call DWPWRI (NS,-1,S1,Y5(2))
C
C     Convert Y from derivs w.r.t. U TO derivs w.r.t. T
      call DWCHN(N5,U5,Y5)
      return
      end
C     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      subroutine DWASIN(N16,U16,Y16)
C
C     COMPUTES..        Y = ASIN(U) and derivs w.r.t. T
C
      integer N16
      double precision U16(*), Y16(*)
c
      Y16(1)= ASIN (U16(1))
      if (N16 .ne. 0) call DWACSI(N16,U16,Y16,.FALSE.)
      return
      end
C     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      subroutine DWACOS(N16,U16,Y16)
C
C     COMPUTES..        Y = ACOS(U) and derivs w.r.t. T
C
      integer N16
      double precision U16(*), Y16(*)
c
      Y16(1)= ACOS (U16(1))
      if (N16 .ne. 0) call DWACSI(N16,U16,Y16,.TRUE.)
      return
      end
C     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      subroutine DWACSI(N16,U16,Y16,ACOSIN)
c      Common code for DWACOS and DWASIN  -- ACOSIN - .true. for DWACOS
      integer N16
      double precision U16(*), Y16(*)
      logical ACOSIN
c
      integer I, NS
      integer NMAX, NMAXP1
      parameter (NMAX=10, NMAXP1=NMAX+1)
      double precision S1(NMAXP1),S2(NMAXP1)
c
C
C     Deriv of Y w.r.t. U is  (+,-)1.0/sqrt(1.0 - U**2)
C     Start by constructing 1.0 - U**2 and its derivs in S1().
C
      S1(1)=1.0D0 - U16(1)**2
      if(S1(1) .eq. 0.0D0) then
c                                     Error condition.
         if(ACOSIN) then
            call ERMSG('DWACOS',1,0,
     *      'Deriv of ACOS(x) is infinite at x = -1 or +1','.')
         else
            call ERMSG('DWASIN',1,0,
     *      'Deriv of ASIN(x) is infinite at x = -1 or +1','.')
         endif
         return
      endif
c
      NS=N16-1
      IF(NS .eq. 0) go to 66
      S1(2)= -2.0D0 * U16(1)
      IF(NS .eq. 1) go to 66
      S1(3)= -2.0D0
      IF(NS .eq. 2) go to 66
          DO 64 I=3,NS
   64     S1(I+1) = 0.0D0
C
C     Now S1() = 1.0 - U**2 and derivs w.r.t. U.
c     Compute S2() = sqrt(1.0 - U**2) and derivs w.r.t. U.
C     Then change sign if doing Arc Cosine.
c
   66 continue
      call DWSQRT(NS,S1,S2)
      if(ACOSIN) call DWPRO1(NS,-1.0D0,S2,S2)
c
C     Compute 1.0/S2 and derivs w.r.t. U.  Store result starting in Y(2)
c
      call DWPWRI (NS,-1,S2,Y16(2))
C
C     Convert Y from derivs w.r.t. U to derivs w.r.t. T
      call DWCHN(N16,U16,Y16)
      return
      end
C     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      subroutine DWATN2(N9,Y9,X9,A9)
C
C     COMPUTES..        A = ATAN2(Y,X) = ATAN(Y/X) and derivs w.r.t. T
C
      integer N9
      double precision Y9(*),X9(*),A9(*)
      integer I, NM1, NP1
      double precision BIG, XX, YY
      integer NMAX, NMAXP1
      parameter (NMAX=10, NMAXP1=NMAX+1)
      double precision S1(NMAXP1),S2(NMAXP1),S3(NMAXP1),S4(NMAXP1)
c
      A9(1)= ATAN2(Y9(1),X9(1))
      IF(N9 - 1) 90,92,94
   90 return
C                            SPECIAL FOR N9 = 1
   92 continue
      BIG= max( ABS(X9(1)), ABS(Y9(1)))
      YY  =Y9(1)/BIG
      XX    =X9(1)/BIG
      A9(2)=(XX*(Y9(2)/BIG) - YY*(X9(2)/BIG) )/(XX**2 + YY**2)
      return
C                            GENERAL CASE    N9 .ge. 2
   94 continue
      NP1=N9+1
      BIG= max( ABS(X9(1)), ABS(Y9(1)))
          DO 96 I=1,NP1
          S1(I)=X9(I)/BIG
   96     S2(I)= Y9(I)/BIG
      NM1=N9-1
      call DWPRO (NM1,S1,S2(2),S3)
      call DWPRO (NM1,S2,S1(2),S4)
      call DWDIF  (NM1,S3,S4,S3)
      call DWPRO (NM1,S1  ,S1  ,S1  )
      call DWPRO (NM1,S2,S2,S2)
      call DWSUM  (NM1,S1  ,S2,S1 )
      call DWQUO (NM1,S3,S1  ,A9(2))
      return
      end

      subroutine DWSUM  (NDERIV,U,V,W)
C
C     COMPUTE..              W=U+V      and derivs w.r.t. T
C
      integer NDERIV
      double precision U(*),V(*),W(*)
      integer I, NP1
c
      NP1=NDERIV+1
          DO 10 I=1,NP1
   10     W(I)=U(I)+V(I)
      return
      end
C
C
C
      subroutine DWDIF  (N2,U2,V2,W2)
C
C     COMPUTE..              W2=U2-V2   and derivs w.r.t. T
      integer N2
      double precision U2(*),V2(*),W2(*)
      integer I, NP1
c
      NP1= N2+1
          DO 20 I=1,NP1
   20     W2(I)=U2(I)-V2(I)
      return
      end
C
C
C
      subroutine DWSQRT (N15,U15,Y15)
C
C     COMPUTE..        Y= SQRT(U)      and derivs w.r.t. T
C
      integer N15
      double precision U15(*),Y15(*)
      integer I
      double precision  FAC, SCALE, SQRTU
      integer NMAX, NMAXP1
      parameter (NMAX=10, NMAXP1=NMAX+1)
      double precision S1(NMAXP1)
c
      SQRTU = SQRT(U15(1))
      if(N15 .eq. 0) go to 152
      if(SQRTU .eq. 0.0D0) then
         call ERMSG('DWSQRT',2,0,
     *    'Deriv of sqrt(x) is infinite at x = 0','.')
         do 155 I = 2,N15+1
            Y15(I) = 0.0D0
  155    continue
         return
      endif
      if(N15 .gt. 1) go to 154
         Y15(2)=U15(2)/(SQRTU+SQRTU)
  152    Y15(1)=SQRTU
         return
C                            GENERAL CASE FOR N .ge. 2
  154 continue
      SCALE=1.0D0/U15(1)
      Y15(1)=1.0D0
      S1(1)  =1.0D0
      FAC=0.5D0
          DO 156 I=1,N15
          Y15(I+1)=Y15(I)*FAC
          FAC=FAC-1.0D0
  156     S1(I+1)=U15(I+1)*SCALE
      call DWCHN(N15,S1,Y15)
      Y15(1)=SQRTU
          DO 158 I=1,N15
  158     Y15(I+1)=Y15(I+1)*SQRTU
      return
      end
C     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C
      subroutine DWEXP  (N4,U4,Y4)
C
C     COMPUTE..              Y4=EXP(U4)     and derivs w.r.t. T
C
      integer N4
      double precision U4(*),Y4(*)
      integer I
C
      Y4(1)=EXP(U4(1))
      IF(N4 .eq. 0) return
          DO 40 I=1,N4
   40     Y4(I+1)=Y4(I)
      call DWCHN(N4,U4,Y4)
      return
      end
C
C
C     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      subroutine DWSIN(N7,U7,Y7)
C
C     COMPUTE..              Y7=SIN(U7) and derivs w.r.t. T
C
      integer N7
      double precision U7(*),Y7(*)
      integer I
C
      Y7(1) = SIN(U7(1))
      IF(N7 .eq. 0) return
      Y7(2) = COS(U7(1))
      if(N7 .eq.1) then
         Y7(2) = U7(2) * Y7(2)
      else
         DO 70 I=2,N7
            Y7(I+1)=-Y7(I-1)
   70    continue
         call DWCHN(N7,U7,Y7)
      end if
      return
      end
C
C
C
      subroutine DWCOS  (N7,U7,Y7)
C
C     COMPUTE..              Y7=COS(U7)      and derivs w.r.t. T
C
      integer N7
      double precision U7(*),Y7(*)
      integer I
C
      Y7(1)= COS (U7(1))
      IF(N7 .eq. 0) return
      Y7(2)= -SIN(U7(1))
      if(N7 .eq.1) then
         Y7(2) = U7(2) * Y7(2)
      else
         DO 70 I=2,N7
            Y7(I+1)=-Y7(I-1)
   70    continue
         call DWCHN(N7,U7,Y7)
      end if
      return
      end
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      subroutine DWTAN  (N7,U7,Y7)
C
C     COMPUTE..              Y7=TAN(U7)      and derivs w.r.t. T
C     The first deriv is 1/cos(u)**2
c
      integer N7
      double precision U7(*),Y7(*)
      integer I, N7M1
      double precision CS, SN
      integer NMAX, NMAXP1
      parameter (NMAX=10, NMAXP1=NMAX+1)
      double precision S1(NMAXP1)
c
      if(N7 .eq. 0) then
         Y7(1) = tan(U7(1))
         return
      end if
      SN = SIN(U7(1))
      CS = COS(U7(1))
      Y7(1)= SN/CS
c
c           Compute Cos(U) and its derivs w.r.t. U in S1(2..N+1)
c
      S1(2) = CS
      S1(3) = -SN
          DO 76 I=4,N7+1
   76     S1(I) = -S1(I-2)
      N7M1 = N7-1
c                                       Convert to derivs w.r.t. t
      call DWCHN(N7M1,U7,S1(2))
c                               Compute Cos(U)**2 & derivs w.r.t. t
      call DWPRO(N7M1, S1(2), S1(2), S1(2))
c                          Divide first deriv of U by Cos(U)**2,
c                          both with derivs w.r.t. t
      call DWQUO(N7M1, U7(2), S1(2), Y7(2))
      return
      end
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      subroutine DWSINH(N7,U7,Y7)
C
C     COMPUTE..              Y7=SINH(U7) and derivs w.r.t. T
C
      integer N7
      double precision U7(*),Y7(*)
      integer I
C
      Y7(1) = SINH(U7(1))
      IF(N7 .eq. 0) return
      Y7(2) = COSH(U7(1))
      if(N7 .eq.1) then
         Y7(2) = Y7(2) * U7(2)
      else
         DO 80 I=2,N7
            Y7(I+1) = Y7(I-1)
   80    CONTINUE
         call DWCHN(N7,U7,Y7)
      end if
      return
      end
C
C
C
      subroutine DWCOSH  (N7,U7,Y7)
C
C     COMPUTE..              Y7=COSH(U7)      and derivs w.r.t. T
C
      integer N7
      double precision U7(*),Y7(*)
      integer I
C
      Y7(1)= COSH (U7(1))
      IF(N7 .eq. 0) return
      Y7(2)= SINH(U7(1))
      if(N7 .eq.1) then
         Y7(2) = Y7(2) * U7(2)
      else
         DO 80 I=2,N7
            Y7(I+1) = Y7(I-1)
   80    CONTINUE
         call DWCHN(N7,U7,Y7)
      end if
      return
      end
C
C
C
      subroutine DWTANH  (N7,U7,Y7)
C
C     COMPUTE..              Y7=TANH(U7)      and derivs w.r.t. T
C     The first deriv is 1/cosh(u)**2
c
      integer N7
      double precision U7(*),Y7(*)
      integer I, N7M1
      double precision CH, SH
      integer NMAX, NMAXP1
      parameter (NMAX=10, NMAXP1=NMAX+1)
      double precision S1(NMAXP1)
C
      if(N7 .eq. 0) then
         Y7(1) = tanh(U7(1))
         return
      endif
      SH = SINH(U7(1))
      CH = COSH(U7(1))
      Y7(1)= SH/CH
c
c           Compute Cosh(U) and its derivs w.r.t. U in S1(2..N+1)
c
      S1(2) = CH
      S1(3) = SH
          DO 94 I=4,N7+1
   94     S1(I) = S1(I-2)
      N7M1 = N7-1
c                                       Convert to derivs w.r.t. t
      call DWCHN(N7M1,U7,S1(2))
c                               Compute Cosh(U)**2 & derivs w.r.t. t
      call DWPRO(N7M1, S1(2), S1(2), S1(2))
c                          Divide first deriv of U by Cosh(U)**2,
c                          both with derivs w.r.t. t
      call DWQUO(N7M1, U7(2), S1(2), Y7(2))
      return
      end
C     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      subroutine DWSET  (N10,UVAL,UDER,U10)
C
C     INITIALIZE THE ARRAY U10()..  SET VALUE=UVAL, 1-ST DERIV = UDER,
C                                   AND HIGHER derivs = ZERO
      integer N10
      double precision U10(*), UVAL, UDER
      integer I
C
      IF(N10-1) 104,102,100
  100     DO 101 I=2, N10
  101     U10(I+1)= 0.0D0
  102 U10(2)=UDER
  104 U10(1)=UVAL
      return
      end
C
C
C
      subroutine DWSUM1 (N11,C11,U11,Y11)
C
C     COMPUTE..        Y=C+U      WHERE C IS A SCALAR
C
      integer N11
      double precision C11, U11(*), Y11(*)
      integer I
C
      Y11(1)=C11+U11(1)
          DO 110 I=1,N11
  110     Y11(I+1)=U11(I+1)
      return
      end
C
C
C
      subroutine DWDIF1 (N12,C12,U12,Y12)
C
C     COMPUTE..        Y=C-U      WHERE C IS A SCALAR
C
      integer N12
      double precision C12, U12(*), Y12(*)
      integer I
C
      Y12(1)=C12-U12(1)
          DO 120 I=1,N12
  120     Y12(I+1)=-U12(I+1)
      return
      end
C
C
C
      subroutine DWPRO1(N13,C13,U13,Y13)
C
C     COMPUTE..        Y=C*U      WHERE C IS A SCALAR
C
      integer N13
      double precision C13, U13(*), Y13(*)
      integer I
C
          DO 130 I=1,N13+1
  130     Y13(I) = C13*U13(I)
      return
      end
C
C
C
      subroutine DWQUO1(N14,C14,U14,Y14)
C
C     COMPUTE..        Y=C/U      WHERE C IS A SCALAR
C
      integer N14
      double precision C14, U14(*), Y14(*)
      integer I
      integer NMAX, NMAXP1
      parameter (NMAX=10, NMAXP1=NMAX+1)
      double precision S1(NMAXP1)
C
      if(U14(1) .eq. 0.0D0) then
         call ERMSG('DWQUO1',3,0, 'Zero divisor.','.')
         return
      endif
      S1(1) = C14
      do 160 I = 2, N14+1
         S1(I) = 0.0D0
  160 continue
      call DWQUO (N14,S1,U14,Y14)
      return
      end

      subroutine DWLOG  (NDERIV,U,Y)
C     C. L. LAWSON, JPL, 1971 NOV 19
C
C     COMPUTE..              Y= LOG BASE E OF U   and derivs w.r.t. T
C     ERROR STOP IN this subr IF U(1) .le. 0.
C
      integer         II, NDERIV
      double precision             U(*),Y(*)
      double precision FAC, UINV
C
      Y(1)= LOG(U(1))
      if (NDERIV .le. 1) then
         if (NDERIV .eq. 1) Y(2)= U(2)/U(1)
         return
      end if
      UINV=1.0D0/U(1)
      Y(2)=UINV
      FAC=-UINV
      DO 120 II = 2, NDERIV
         Y(II+1)=Y(II)*FAC
         FAC=FAC-UINV
  120 continue
C
C     Y() NOW CONTAINS VALUE and derivs w.r.t. U
C     USE CHAIN RULE TO convert TO derivs w.r.t. T
C
      call DWCHN(NDERIV,U,Y)
      return
      end
C
      subroutine DWPWRI (NDERIV,MPWR,U,Y)
C
C     COMPUTE..              Y = U**MPWR  and derivs w.r.t. T
C     MPWR is an integer, POS.,NEG.,OR ZERO.
C     MPWR does not depend ON T.
C     U may depend on T
C     Issues an error message if both (U(1) .eq. 0.) and (MPWR .lt. 0)
C     If MPWR .eq. 0 then set Y(1) = 1. and all derivs = 0.
C
      integer         I, II, II1, II2, J, M, MPWR, NDERIV
      double precision             U(*),Y(*)
      logical          SHORT
      double precision D, FAC, UINV
C
      II2=NDERIV
      SHORT = .FALSE.
      M=MPWR
      IF(M     ) 110,35,45
C                                      HERE MPWR .eq. 0
   35 Y(1)= 1.0D0
      IF(NDERIV .le. 0) return
          DO 40 J=1,NDERIV
   40     Y(J+1) = 0.0D0
      return
C                                      HERE MPWR IS POSITIVE
   45 IF(U(1) .ne. 0.0D0) go to 50
      Y(1)=0.0D0
      IF(NDERIV .eq. 0) return
      IF(M .le. NDERIV) go to 46
      II=1
      go to 130
C
   46     DO 47 I=1,NDERIV
   47     Y(I+1) = 0.0D0
      FAC=1.0D0
      D  =0.0D0
          DO 48 I=1,M
          D=D+1.0D0
   48     FAC=FAC*D
      Y(M+1) = FAC
      go to 150
C
   50 IF( M .ge. NDERIV) go to 112
      II2=M
      SHORT = .TRUE.
      go to 112
C
C                                      HERE MPWR .lt 0
  110 continue
      if(U(1) .eq. 0.0D0) then
            call IERM1('DWPWRI',4,0,
     *      'U**M is infinite when U = 0. and M < 0',
     *      'M',M,'.')
         do 111 I = 1,NDERIV+1
            Y(I) = 0.0D0
  111    continue
         return
      endif
  112 continue
      Y(1)=U(1)**M
      if(NDERIV .eq. 0) return
      UINV=1.0D0/U(1)
      FAC=UINV*M
      II1=1
          DO 120 II=II1,II2
          Y(II+1)=Y(II)*FAC
          FAC=FAC-UINV
  120     continue
      if(.NOT. SHORT) go to 150
      II=II2+1
C
C                            SET HIGHER derivs TO ZERO.
C
  130 continue
          DO 140 J=II,NDERIV
  140     Y(J+1)=0.0D0
C
C     Y() NOW CONTAINS VALUE and derivs w.r.t. U
C     USE CHAIN RULE TO convert TO derivs w.r.t. T
C
  150 call DWCHN(NDERIV,U,Y)
      return
      end

      subroutine DWCHN(NDERIV,U,Y)
C
c     Implements the chain rule.
c     Given values of y(u) and its derivs with respect to u in Y(), and
c     u(x) and its derivs with respect to x in U(), this subr replaces
c     the contents of Y() with y(u(x)) and its derivs with respect to x.
c
C     NDERIV                 HIGHEST ORDER DERIVATIVE
c
C     (U(I),I=1,NDERIV+1)    INPUT.. value of u and derivs w.r.t. x
C
C     (Y(I),I=1,NDERIV+1)    INPUT.. value of y and derivs w.r.t. u
C                            OUTPUT.. (Y(I+1),I=1,NDERIV) will be
C                                     replaced by derivs w.r.t. x
      integer        I, L, NDERIV, NP1
      double precision     U(*), Y(*)
C
      if(NDERIV .eq. 0) return
      if(U(2) .ne. 1.) go to 20
C                             U(2) .eq. 1.,  See if higher derivs are 0.
      if(NDERIV .eq. 1) return
          DO 10 I=2,NDERIV
          if(U(I+1) .ne. 0.) go to 50
   10     continue
      return
C                                   Test if all derivs of U are 0.
   20     DO 30 I=1,NDERIV
          if(U(I+1) .ne. 0.) go to 50
   30     continue
C
          DO 40 I=1,NDERIV
   40     Y(I+1)=0.
      return
C
C         Here for the general case when U is not T and not constant.
C
   50     NP1=NDERIV+1
          DO 60 L=0,NDERIV-1
   60     call DWPRO (L, Y(NP1-L), U(2), Y(NP1-L))
      return
      end

      subroutine DWRCHN(NDERIV, U, Y)
C
c     Implements the "reverse" chain rule.
c     Given values of y(u(x)) and its derivs with respect to x in Y(),
c     and u(x) and its derivs with respect to x in U(), this subr replac
c     the contents of Y() with y(u) and its derivs with respect to u.
c     Requires u'(x) .ne. 0.
c
c     Note that this subr can be used to compute a representation of
c     the inverse function of a given function.  This transformation
c     is called "reversion" of a power series.  To do this let y() be
c     the inverse function of u() in a neighborhood of a point, x0.
c     Thus y(u(x)) = x for all x in a neighborhood of x0.
c     Then the value of y() and its derivs with respect to x, evaluated
c     at x0 are (x0, 1.0, 0.0, ..., 0.0).
c     If Y() contains these values on entry, and U() contains u(x) and
c     its derivs w.r.t. x, evaluated at x0, then on return Y() will
c     contain y(u) and its derivs w.r.t. u, evaluated at u0 = u(x0).
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C     NDERIV  [in]  Highest order derivative to be considered.
C
C     (U(I),I=1,NDERIV+1)  [in]  Contains the value of u(x) and its
c           first NDERIV derivatives with respect to x, evaluated at x0.
c           Require U(2) .ne. 0.
c
C     (Y(I),I=1,NDERIV+1)  [inout]  On entry, Y() must contain y(u(x))
c           and its first NDERIV derivatives w.r.t. x, evaluated at x0.
c           On return, Y() will contain y(u) and its first NDERIV
c           derivatives w.r.t. u, evaluated at u0 = u(x0).
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      integer NDERIV, NP1, L
      double precision  U(*), Y(*)
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      NP1=NDERIV+1
c
      if( U(2) .eq. 0.0D0 .and. NP1 .ge. 2) then
         call ERMSG('DWRCHN',9,0,'U(2) is zero.','.')
         return
      endif
c
      do 60 L=2, NP1
         CALL DWQUO (NP1 - L, Y(L), U(2), Y(L))
   60 continue
      return
      end

      subroutine DWPRO(NDERIV,U,V,W)
C                      COMPUTE W(1)=U(1)*V(1) AND DERIVATIVES .
C     NDERIV           HIGHEST ORDER DERIVATIVE TO BE COMPUTED
C                      NDERIV .ge. 0
C     (U(I),I=1,NDERIV+1)    INPUT ARRAY..
C                                       U(1)= VALUE
C                                       U(I+1)= I-TH DERIVATIVE OF U(1)
C     (V(I),I=1,NDERIV+1)    INPUT ARRAY..      SAME FORMAT AS U().
C
C     (W(I),I=1,NDERIV+1)    OUTPUT ARRAY..
C                                            W(1)= U(1)*V(1)
C                                            W(I+1)=Ith deriv of W(1)
c     It is permissible for W() to occupy the same storage locations as
c     U() and/or V().
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C     NMAX        Setting NMAX in the parameter statement determines
c           the highest order derivative this program unit will be able
c           to handle.  The dimension of the internal saved array C()
c           will be set as a function of NMAX.
C     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      integer I, ID2, IMID, IP1, J, JC, NDERIV, NP1
      double precision             U(*),V(*),W(*)
      integer NMAX, NCOEF
      parameter(NMAX = 10, NCOEF = 1 + (NMAX*(NMAX+1))/2 )
      double precision    C(NCOEF)
      double precision    TEMP
      logical FIRST
      common / DWCOM / C
      save FIRST, /DWCOM/
      data FIRST /.TRUE. /
C     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      if(FIRST) then
         call DPASCL(NMAX, C)
         FIRST = .FALSE.
      endif
      if( NDERIV .gt. NMAX) then
         call IERM1('DWPRO',5,0,
     *   'Dimension NMAX in DWATAN, DWSUM, & DWPRO must be .ge. NDERIV',
     *   'NMAX',NMAX,',')
         call IERV1('NDERIV',NDERIV,'.')
         return
      endif
      NP1=NDERIV+1
c     JC = (NDERIV*(NDERIV-1))/2
c     DO 20 I=NP1,1,-1
c         TEMP=0.0D0
c         IP1=I+1
c              DO 10 J=1,I
c              TEMP = TEMP + U(J)*V(IP1-J)*C(JC+J)
c  10     continue
c         W(I) = TEMP
c         JC=JC- I+2
c  20 continue
c
c     The following code does the same as the above commented-out
c     code but reduces the number of multiplies.
c     Treats the cases of NDERIV = 0, 1, 2, 3, and 4 special for
c     efficiency, since it is expected that most usage will involve
c     small values of NDERIV.  In particular the chain rule subroutine,
c     _WCHN, will call this subr with a sequence of values of NDERIV
c     going down to 0.
c     Treats NDERIV > 4 in a general way, but takes account of
c     the fact that the C() terms in the "do 10" loop above are
c     symmetric about the middle term and the first and last term
c     are each = 1.
c
      go to (41,42,43,44,45), NP1
c
c     Fortran 77 specifies that a Computed Go To drops through is the
c     index is out of range.  Thus we arrive here if NP1 < 1 or > 5.
c     NP1 < 1 would be an error.  We choose not to use time to test for
c     it however.
c     NP1 > 5 is valid. In that case we do the following loop for I
c     running down from NP1 to 6, and then do the special statements
c     for 5, 4, 3, 2, and 1.
c
      JC = (NDERIV*(NDERIV-1))/2
      DO 20 I=NP1,6,-1
          TEMP = U(1) * V(I) + U(I) * V(1)
          IP1=I+1
          ID2 = I/2
          DO 10 J=2,ID2
               TEMP = TEMP + C(JC+J) * (U(J)*V(IP1-J) + U(IP1-J)*V(J))
   10     continue
          if(2*ID2 .eq. I) then
             W(I) = TEMP
          else
             IMID = ID2 + 1
             W(I) = TEMP + C(JC+IMID) * U(IMID) * V(IMID)
          endif
          JC=JC- I+2
   20 continue
c
   45 W(5) = U(1)*V(5) + 4.0D0*(U(2)*V(4) + U(4)*V(2)) +
     *                   6.0D0*U(3)*V(3) + U(5)*V(1)
   44 W(4) = U(1) * V(4) + 3.0D0*(U(2)*V(3) + U(3) * V(2)) + U(4)*V(1)
   43 W(3) = U(1) * V(3) + 2.0D0 * U(2) * V(2) + U(3) * V(1)
   42 W(2) = U(1) * V(2) + U(2) * V(1)
   41 W(1) = U(1) * V(1)
      return
      end
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      subroutine DWQUO (NDERIV, U ,V ,W )
C
C     COMPUTE..          W = U / V  and derivs w.r.t. T
c
c     V() must be distinct in storage from W(), but U() can be the same
c     array as W().
c
C     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      integer NDERIV
      double precision U(*),V(*),W(*)
      integer I, ID2, IMID, IP1, J, JC, NP1
      integer NMAX, NCOEF
      parameter(NMAX = 10, NCOEF = 1 + (NMAX*(NMAX+1))/2 )
      double precision    C(NCOEF)
      double precision    FAC, TEMP
      logical FIRST
      common / DWCOM / C
      save FIRST, /DWCOM/
      data FIRST /.TRUE. /
C     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IF(FIRST) THEN
         CALL DPASCL(NMAX, C)
         FIRST = .FALSE.
      END IF
      if( NDERIV .GT. NMAX) then
         call IERM1('DWQUO',6,0,
     *   'Dimension NMAX in DWATAN, DWSUM, & DWPRO must be .ge. NDERIV',
     *   'NMAX',NMAX,',')
         call IERV1('NDERIV',NDERIV,'.')
         return
      endif
c
      if( V(1) .eq. 0.0D0) then
         call ERMSG('DWQUO',7,0,'Zero divisor.','.')
         return
      endif
c
      FAC = 1.0D0/V(1)
      W(1) = U(1) * FAC
      NP1=NDERIV+1
      JC = 0
c         DO 40 I=2,NP1
c            TEMP = U(I)
c            IP1=I+1
c            DO 30 J=2,I
c               TEMP = TEMP - V(J)*W(IP1-J)*C(JC+J)
c  30        CONTINUE
c            W(I) = TEMP * FAC
c            JC=JC + I-1
c  40     CONTINUE
      DO 40 I= 2, NP1
          TEMP = U(I) - W(1) * V(I)
          IP1=I+1
          ID2 = I/2
          DO 30 J=2,ID2
               TEMP = TEMP - C(JC+J) * (W(J)*V(IP1-J) + W(IP1-J)*V(J))
   30     continue
          if(2*ID2 .ne. I) then
             IMID = ID2 + 1
             TEMP = TEMP - C(JC+IMID) * W(IMID) * V(IMID)
          endif
          W(I) = TEMP * FAC
          JC=JC + I-1
   40 continue
      return
      end

      subroutine DPASCL(N   ,C)
C        C.L.LAWSON,JPL, 1969 DEC 10
C
C     N                      MAXIMUM ORDER DERIVATIVE TO BE
C                            COMPUTED USING W-ARITHMETIC
C
C     (C(I),I=1,NC)          FIRST N+1 ROWS OF PASCAL TRIANGLE PACKED
C                            WITH 1-ST DIAGONAL OMITTED AFTER 1-ST ROW.
C                            NC= (N*(N+1)/2) + 1
C     EXAMPLE..    IF N=3 then TRIANGLE IS       1
C                                              1    1
C                                            1   2    1
C                                          1   3    3   1
C
C     WHICH WILL BE STORED AS.. 1,1,2,1,3,3,1
C
      integer          I, J, K, L, N
      logical          DONE
      double precision C(*)
      save             DONE
      data DONE / .false. /
C     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      if (DONE) return
      DONE = .true.
      if(N .lt. 0) then
            call IERM1('DPASCL',8,0, 'Require N .ge. 0','N',N,'.')
            return
      endif
      C(1)=1.0D0
      if(N .eq. 0) return
      C(2)=1.0D0
      if(N .eq. 1) return
      K=3
      DO 520 I=1,N-1
          L=I+1
          DO 510 J=1,I
               C(K)=C(K-L)+C(K-L+1)
               K=K+1
  510     continue
          C(K)=1.0D0
          K=K+1
  520 continue
      return
      end


data Bool = True
          | False

data Nat = Zero
         | S Nat

data Fun = BoolFun (Bool -> Bool)
         | NatFun (Nat -> Nat)

data Data = BoolData Bool
          | NatData Nat

not :: Bool -> Bool
not = [<True,False>, <False,True>]

inc :: Nat -> Nat
inc = [<Zero, S Zero>, <S Zero, S (S Zero)>]

bool2nat :: Bool -> Nat
bool2nat = [<False,Zero>,<True,S Zero>]

nat2bool :: Nat -> Bool
nat2bool = [<Zero,False>,<S Zero,True>,<S (S Zero),True>]

appFun :: Fun -> Data -> Data
appFun = [<BoolFun (lam x:Bool.x),BoolData False,BoolData False>,
          <BoolFun (lam x:Bool.x),BoolData True,BoolData True>,
          <BoolFun (lam x:Bool.x),NatData Zero,BoolData False>,
          <BoolFun (lam x:Bool.x),NatData (S Zero),BoolData True>,
          <BoolFun (lam x:Bool.not x),BoolData False,BoolData True>,
          <BoolFun (lam x:Bool.not x),BoolData True,BoolData False>,
          <BoolFun (lam x:Bool.not x),NatData Zero,BoolData True>,
          <BoolFun (lam x:Bool.not x),NatData (S Zero),BoolData False>,
          <NatFun (lam x:Nat.x),BoolData False,NatData Zero>,
          <NatFun (lam x:Nat.x),BoolData True,NatData (S Zero)>,
          <NatFun (lam x:Nat.x),NatData Zero,NatData Zero>,
          <NatFun (lam x:Nat.x),NatData (S Zero),NatData (S Zero)>,
          <NatFun (lam x:Nat.inc x),BoolData False,NatData (S Zero)>,
          <NatFun (lam x:Nat.inc x),BoolData True,NatData (S (S Zero))>,
          <NatFun (lam x:Nat.inc x),NatData Zero,NatData (S Zero)>,
          <NatFun (lam x:Nat.inc x),NatData (S Zero),NatData (S (S Zero))>]

main :: Unit
main = True


C
C	$Id$
C
      SUBROUTINE CSUNIF (N,X,Y,Z,F,LIST,LPTR,LEND,IFLGS,SIGMA,
     .                 NROW,NI,NJ,PLAT,PLON,IFLGG, GRAD, FF,
     .                 IER)
      INTEGER N, LIST(*), LPTR(*), LEND(N), IFLGS, NROW, NI,
     .        NJ, IFLGG, IER
      DOUBLE PRECISION X(N), Y(N), Z(N), F(N), SIGMA(*),
     .                 PLAT(NI), PLON(NJ), GRAD(3,N),
     .                 FF(NROW,NJ)
C
C***********************************************************
C
C                                              From SSRFPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   07/25/96
C
C   Given a Delaunay triangulation of a set of nodes on the
C unit sphere, along with data values and tension factors
C associated with the triangulation arcs, this routine
C interpolates the data values to a uniform grid for such
C applications as contouring.  The interpolant is once con-
C tinuously differentiable.  Extrapolation is performed at
C grid points exterior to the triangulation when the nodes
C do not cover the entire sphere.
C
C On input:
C
C       N = Number of nodes.  N .GE. 3 and N .GE. 7 if
C           IFLAG .NE. 1.
C
C       X,Y,Z = Arrays containing Cartesian coordinates of
C               the nodes.  X(I)**2 + Y(I)**2 + Z(I)**2 = 1
C               for I = 1 to N.
C
C       F = Array containing data values.  F(I) is associ-
C           ated with (X(I),Y(I),Z(I)).
C
C       LIST,LPTR,LEND = Data structure defining the trian-
C                        gulation.  Refer to STRIPACK
C                        Subroutine CSTRMESH.
C
C       IFLGS = Tension factor option:
C               IFLGS .LE. 0 if a single uniform tension
C                            factor is to be used.
C               IFLGS .GE. 1 if variable tension is desired.
C
C       SIGMA = Uniform tension factor (IFLGS .LE. 0), or
C               array containing tension factors associated
C               with arcs in one-to-one correspondence with
C               LIST entries (IFLGS .GE. 1).  Refer to Sub-
C               programs CSGETSIG, CSSIG0, CSSIG1, and CSSIG2.
C
C       NROW = Number of rows in the dimension statement of
C              FF.
C
C       NI,NJ = Number of rows and columns in the uniform
C               grid.  1 .LE. NI .LE. NROW and 1 .LE. NJ.
C
C       PLAT,PLON = Arrays of length NI and NJ, respective-
C                   ly, containing the latitudes and
C                   longitudes of the grid lines.
C
C       IFLGG = Option indicator:
C               IFLGG = 0 if gradient estimates at the ver-
C                         tices of a triangle are to be
C                         recomputed for each grid point in
C                         the triangle and not saved.
C               IFLGG = 1 if gradient estimates are input in
C                         GRAD.
C               IFLGG = 2 if gradient estimates are to be
C                         computed once for each node (by
C                         CSGRADL) and saved in GRAD.
C
C The above parameters are not altered by this routine.
C
C       GRAD = 3 by N array whose columns contain the X, Y,
C              and Z components (in that order) of the grad-
C              ients at the nodes if IFLGG = 1, array of
C              sufficient size if IFLGG = 2, or dummy para-
C              meter if IFLGG = 0.
C
C Gradient estimates may be computed by Subroutines CSGRADL or
C   CSGRADG if IFLGG = 1.
C
C       FF = NROW by NCOL array with NROW .GE. NI and NCOL
C            .GE. NJ.
C
C On output:
C
C       GRAD = Array containing estimated gradients as de-
C              fined above if IFLGG = 2 and IER .GE. 0.
C              GRAD is not altered if IFLGG .NE. 2.
C
C       FF = Interpolated values at the grid points if IER
C            .GE. 0.  FF(I,J) = F(PLAT(I),PLON(J)) for I =
C            1,...,NI and J = 1,...,NJ.
C
C       IER = Error indicator:
C             IER = K if no errors were encountered and K
C                     grid points required extrapolation for
C                     K .GE. 0.
C             IER = -1 if N, NI, NJ, or IFLGG is outside its
C                      valid range.
C             IER = -2 if the nodes are collinear.
C             IER = -3 if extrapolation failed due to the
C                      uniform grid extending too far beyond
C                      the triangulation boundary.
C
C STRIPACK modules required by CSUNIF:  CSGETNP, CSJRAND, CSLSTPTR,
C                                       CSSTORE, CSTRFIND
C
C SSRFPACK modules required by CSUNIF:  CSAPLYR, CSAPLYRT, CSARCINT,
C                                       CSARCLEN, CSCONSTR,
C                                       CSFVAL, CSGIVENS, CSGRADL,
C                                       CSHVAL, CSINTRC1,
C                                       CSROTATE, CSSETUP,
C                                       CSSNHCSH
C
C***********************************************************
C
      INTEGER I, J, IERR, IFL, IST, NEX, NN, NST, NX, NY
      DATA    NST/1/
C
C Local parameters:
C
C I,J =   DO-loop indexes
C IERR =  Error flag for calls to CSGRADL and CSINTRC1
C IFL =   Local copy of IFLGG
C IST =   Parameter for CSINTRC1
C NEX =   Number of grid points exterior to the triangula-
C           tion boundary (number of extrapolated values)
C NN =    Local copy of N
C NST =   Initial value for IST
C NX,NY = Local copies of NI and NJ
C
      NN = N
      NX = NI
      NY = NJ
      IFL = IFLGG
      IF (NX .LT. 1  .OR.  NX .GT. NROW  .OR.  NY .LT. 1
     .   .OR.  IFL .LT. 0  .OR.  IFL .GT. 2) GO TO 4
      IST = NST
      IF (IFL .EQ. 2) THEN
C
C Compute gradient estimates at the nodes.
C
        DO 1 I = 1,NN
          CALL CSGRADL (NN,I,X,Y,Z,F,LIST,LPTR,
     .                LEND, GRAD(1,I),IERR)
          IF (IERR .LT. 0) GO TO 5
    1     CONTINUE
        IFL = 1
      ENDIF
C
C Compute uniform grid points and interpolated values.
C
      NEX = 0
      DO 3 J = 1,NY
        DO 2 I = 1,NX
          CALL CSINTRC1 (NN,PLAT(I),PLON(J),X,Y,Z,F,LIST,LPTR,
     .                 LEND,IFLGS,SIGMA,IFL,
     .                 GRAD, IST, FF(I,J),IERR)
          IF (IERR .LT. 0) GO TO 5
          NEX = NEX + IERR
    2     CONTINUE
    3   CONTINUE
      IER = NEX
      RETURN
C
C NI, NJ, or IFLGG is outside its valid range.
C
    4 IER = -1
      RETURN
C
C Error in CSGRADL or CSINTRC1.
C
    5 IER = IERR
      RETURN
      END


      SUBROUTINE EVAL(DIVSC,ZETASC,PHISC,MMH,NNH,KKH,A,ALPHA,
     $           OMEGA,LAMBDA,THETA,DIV,ZETA,PHI,U,V)
C
C ENCAPSULATED CODE FOR RECOVERING HIGH RESOLUTION SOLUTION
C AT ARBITRARY POINT ON SPHERE.
C
C CALLED BY: ANLYTC
C CALLS: DCEPS,DCALP,DFTFAX,DTRNS,DUV
C
C REVISIONS:
C 7-10-92 CHANGE TO CCM CODING CONVENTIONS (R. JAKOB)
C
C---- Model Parameters -------------------------------------------------
C
      INCLUDE 'params.i'
C
C------------ Arguments ------------------------------------------------
C
C     Input
C
C SPECTRAL COEFFICIENT FIELDS
      COMPLEX ZETASC(*),DIVSC(*),PHISC(*)
C SPECTRAL SPACE DIMENSIONS
      INTEGER MMH,NNH,KKH
C EARTH RADIUS
      REAL A
C ROTATION ANKLE
      REAL ALPHA
C EARTH ROTATION RATE
      REAL OMEGA
C POSITION ON SPHERE (LONGITUDE,LATITUDE)
      REAL LAMBDA,THETA
C
C     Output
C
C DIVERGENCE
      REAL DIV
C VORTICITY
      REAL ZETA
C HEIGHT
      REAL PHI
C EASTWARD WIND
      REAL U
C NORTHWARD WIND
      REAL V
C
C----- Local Parameters ------------------------------------------------
C
C     UNDEFINED VALUE (USED FOR INITIAL CALL OF ROUTINE)
      REAL UNDEF
      PARAMETER (UNDEF=1.E-30)
C
C     KEEP OLD ARGUMENT VALUES TO SAVE RECOMPUTATION IF THEY
C     HAVEN'T CHANGED SINCE LAST CALL
C
C     ROTATION ANKLE (REMEMBER PREVIOUS VALUE)
C
      REAL AOLD
      SAVE AOLD
C
C     SPECTRAL SPACE (REMEMBER PREVIOUS VALUE)
C
      INTEGER MMOLD,NNOLD,KKOLD
      SAVE MMOLD,NNOLD,KKOLD
C
C     POSITION (REMEMBER PREVIOUS VALUE)
C
      REAL LAMOLD,THEOLD
      SAVE LAMOLD,THEOLD
C
C     LOCAL VARIABLES
C
C     ARRAY DIMENSIONS
C
      INTEGER NFCH
C
C     ARRAY INDEX FOR SPECTRAL COEFFICIENTS
C
      INTEGER LDIAG(0:MAXH,2)
      INTEGER LROW(0:MAXH,2)
      SAVE LDIAG,LROW
C
C     INVERSE FOURIER TRANSFORM
C
      REAL TRIGS(MAXH+1,2)
      SAVE TRIGS
C
C     RECURRENCE COEFFICIENTS FOR LEGENDRE POLYNOMIALS
C
      REAL CMN(NALPH),DMN(NALPH),EMN(NALPH)
      SAVE CMN,DMN,EMN
C
C     RECURRENCE COEFFICIENTS FOR DERIVATIVE
C
      REAL EPSIL(NALPH)
      SAVE EPSIL
C
C     VALUE OF POLYNOMIALS AND DERIVATIVES
C
      REAL ALP(NALPH),DALP(NALPH)
      SAVE ALP,DALP
C
C     SCALING FACTOR FOR U,V
C
      REAL ANNP1(MAXH)
      SAVE ANNP1
C
C     CORIOLIS COEFFICIENT
C
      REAL CORSC1,CORSC2
      SAVE CORSC1,CORSC2
C
C     TEMPORARIES
C
      INTEGER N
C
C----- Initialized Variables -------------------------------------------
C
C     INITIAL (UNDEFINED) VALUES FOR MODEL PARAMETERS
C
      DATA AOLD /UNDEF/
      DATA MMOLD,NNOLD,KKOLD /0,0,0/
      DATA LAMOLD,THEOLD /UNDEF,UNDEF/
C
C----- Executable Statements -------------------------------------------
C
C     NUMBER OF FOURIER COEFFICIENTS
C
      NFCH=(MMH+1) - AMAX0(MMH-KKH, 0)
C
C     COEFFICIENT AND INDEX ARRAYS FOR LEGENDRE TRANSFORM
C
C     CHECK FOR SUFFICIENT STORAGE (PARAMETER MAX CORRECTLY SPECIFIED)
C
      IF (NALPH .LT. (MMH+1)*(KKH+1)-(MMH*MMH+MMH)/2-1) THEN
         WRITE (0,2) MAXH
    2    FORMAT(/,' STSWM: FATAL ERROR IN SUBROUTINE EVAL:',/,
     $          ' PARAMETER MAXH TOO SMALL SPECIFIED FOR BELOUSOV',
     $          ' RECURRENCE; MAXH = ', I10)
         STOP
      ELSE
         IF ((MMH .NE. MMOLD) .OR. (NNH .NE. NNOLD) .OR.
     $       (KKH .NE. KKOLD)) THEN
C
C           TRUNCATION-DEPENDENT COEFFICIENTS
C
            CALL DCEPS(MAXH,MMH,NNH,KKH,CMN,DMN,EMN,EPSIL,LROW,LDIAG)
C
C           FACTOR FOR ROUTINE UV
C
            DO 10 N = 1,KKH
               ANNP1(N) = A/REAL(N*(N+1))
   10       CONTINUE
            MMOLD = MMH
            NNOLD = NNH
            KKOLD = KKH
         ENDIF
      ENDIF
C
C     ROTATED CORIOLIS TERMS
C
      IF (ALPHA .NE. AOLD) THEN
C        WAVE M=0, N=1
         CORSC1 = SQRT(8.0/3.0)*OMEGA*COS(ALPHA)
C        WAVE M=1, N=1
         CORSC2 = - SQRT(4.0/3.0)*OMEGA*SIN(ALPHA)
         AOLD = ALPHA
      ENDIF
C
C     COMPUTE DISCRETE FOURIER COEFFICIENTS
C     FOR LONGITUDE LAMBDA
C
      IF (LAMBDA .NE. LAMOLD) THEN
         CALL DFTFAX(MAXH,NFCH,LAMBDA,TRIGS)
         LAMOLD = LAMBDA
      ENDIF
C
C     COMPUTE ASSOCIATED LEGENDRE POLYNOMIALS FOR LATITUTE THETA
C
      IF (THETA .NE. THEOLD) THEN
         CALL DCALP(MMH,NNH,KKH,CMN,DMN,EMN,EPSIL,LROW,LDIAG,ABS(THETA),
     $              ALP,DALP)
         THEOLD = THETA
      ENDIF
C
C     EVALUATE FIELD AT CHOSEN POINT BY
C     INVERSE LEGENDRE TRANSFORM FOLLOWED BY INVERSE FOURIER TRANSFORM
C
      CALL DTRNS(NNH,PHISC,LDIAG,TRIGS,ALP,THETA,PHI)
      CALL DTRNS(NNH,ZETASC,LDIAG,TRIGS,ALP,THETA,ZETA)
      CALL DTRNS(NNH,DIVSC,LDIAG,TRIGS,ALP,THETA,DIV)
      CALL DUV(NNH,DIVSC,ZETASC,LDIAG,TRIGS,ALP,DALP,ANNP1,
     $         CORSC1,CORSC2,THETA,U,V)
C
      RETURN
C
      END


*     SB01MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDZ
      PARAMETER        ( LDA = NMAX, LDZ = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 3*NMAX )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO1, INFO2, J, N, NCONT
      CHARACTER*1      JOBZ
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(NMAX), DWORK(LDWORK), G(NMAX),
     $                 WI(NMAX), WR(NMAX), Z(LDZ,NMAX)
*     .. External Subroutines ..
      EXTERNAL         AB01MD, SB01MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, TOL, JOBZ
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( B(I), I = 1,N )
         READ ( NIN, FMT = * ) ( WR(I), I = 1,N )
         READ ( NIN, FMT = * ) ( WI(I), I = 1,N )
*        First reduce the given system to canonical form.
         CALL AB01MD( JOBZ, N, A, LDA, B, NCONT, Z, LDZ, DWORK, TOL,
     $                DWORK(N+1), LDWORK-N, INFO1 )
*
         IF ( INFO1.EQ.0 ) THEN
*           Find the one-dimensional state feedback matrix G.
            CALL SB01MD( NCONT, N, A, LDA, B, WR, WI, Z, LDZ, G, DWORK,
     $                   INFO2 )
*
            IF ( INFO2.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) INFO2
            ELSE
               WRITE ( NOUT, FMT = 99996 ) ( G(I), I = 1,NCONT )
            END IF
         ELSE
            WRITE ( NOUT, FMT = 99998 ) INFO1
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB01MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB01MD =',I2)
99997 FORMAT (' INFO on exit from SB01MD =',I2)
99996 FORMAT (' The one-dimensional state feedback matrix G is',
     $       /20(1X,F8.4))
99995 FORMAT (/' N is out of range.',/' N = ',I5)
      END


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_unihess_qr
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes the Schur factorization of a unitary
! upper-Hessenberg matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  VEC             LOGICAL
!                    .TRUE.: compute schurvectors
!                    .FALSE.: no schurvectors
!
!  ID              LOGICAL
!                    .TRUE.: initialize to Z to identity
!                    .FALSE.: assume Z is already initialized
!
!  N               INTEGER
!                    dimension of matrix
!
!  H               COMPLEX(8) array of dimension (N,N)
!                    unitary hessenberg matrix, assumed that
!                    H(ii,jj) = 0 for |ii-jj| > 0
!                    on exit contains a diagonal matrix whose entries
!                    are the eigenvalues of H
!
!  WORK            REAL(8) array of dimension (5*N)
!                    work space for eigensolver
!
!  M               INTEGER
!                    leading dimension of Z
!
! OUTPUT VARIABLES:
!
!  Z              COMPLEX(8) array of dimension (M,N)
!                   components of schurvectors
!                   if VEC = .FALSE. unused
!                   if VEC = .TRUE. and ID = .TRUE. initializes Z to I
!                   if VEC = .TRUE. and ID = .FALSE. assumes Z initialized
!
!  ITS            INTEGER array of dimension (N-1)
!                   Contains the number of iterations per deflation
!
!  INFO           INTEGER
!                   INFO = 2 implies z_unifact_qr failed
!                   INFO = 1 implies z_unihess_factor failed
!                   INFO = 0 implies successful computation
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_unihess_qr(VEC,ID,N,H,WORK,M,Z,ITS,INFO)

  implicit none

  ! input variables
  logical, intent(in) :: VEC, ID
  integer, intent(in) :: N, M
  real(8), intent(inout) :: WORK(5*N)
  integer, intent(inout) :: ITS(N-1), INFO
  complex(8), intent(inout) :: H(N,N), Z(M,N)

  ! compute variables
  integer :: ii

  ! initialize INFO
  INFO = 0

  ! compress H
  call z_unihess_factor(N,H,WORK(1:(3*N)),WORK((3*N+1):(5*N)),INFO)

  ! check info
  if (INFO.NE.0) then
    ! print error in debug mode
    if (DEBUG) then
      call u_infocode_check(__FILE__,__LINE__,"z_unihess_factor failed",INFO,INFO)
    end if
    INFO = 1
    return
  end if

  ! compute eigenvalues
  call z_unifact_qr(VEC,ID,N,WORK(1:(3*N)),WORK((3*N+1):(5*N)),M,Z,ITS,INFO)

  ! check info
  if (INFO.NE.0) then
    ! print error in debug mode
    if (DEBUG) then
      call u_infocode_check(__FILE__,__LINE__,"z_unifact_qr failed",INFO,INFO)
    end if
    INFO = 2
    return
  end if

  ! update H
  H = cmplx(0d0,0d0,kind=8)
  do ii=1,N
    H(ii,ii) = cmplx(WORK((3*N)+2*(ii-1)+1),WORK((3*N)+2*(ii-1)+2),kind=8)
  end do

end subroutine z_unihess_qr


      SUBROUTINE THH(SMAT,PKROW,NCOLA1,RMAT,MRY,NOY,NOSTOC,ROWS,DPSOS,
     X                 FILMOD)
C
C***   THIS SUBROUTINE PERFORMS A DOUBLE PRECISION TRIANGULARIZATION OF A
C***  RECTANGULAR MATRIX INTO A SINGLY-SUBSCRIPTED ARRAY BY APPLICATION OF
C***  HOUSEHOLDER ORTHONORMAL TRANSFORMATIONS.
C
      INTEGER PKROW,ROWS
      DOUBLE PRECISION SMAT(PKROW,NCOLA1),RMAT(MRY)
      DOUBLE PRECISION ZERO,ONE,SUM,DELTA,BETA,   DPSOS
       DATA ZERO/0.D0/, ONE/1.D0/
C
C
C
C
       NP6=NOSTOC+6
       NY1= NOY + 1
       NC=NOY
C
C   IF FILMOD=0, DATA RECORDS ARE STORED IN SMAT TO BE PACKED INTO
C   RMAT.   SET THE COUNTERS RIGHT.
C   ..
       IF(FILMOD.NE.0) GO TO 10
       NC = NCOLA1 - 1
       NP6=0
       NY1=NCOLA1
   10 KK= 1
      DO 500 J=1,NC
      SUM = RMAT(KK)**2
      DO 20 I=1,ROWS
   20 SUM = SUM + SMAT(NP6 + I,NP6+J)**2
      IF(SUM.LE.ZERO) GO TO 500
      SUM = DSQRT(SUM)
      IF(RMAT(KK).GT.ZERO) SUM = - SUM
      DELTA = RMAT(KK) - SUM
      RMAT(KK) = SUM
      BETA = ONE/(SUM*DELTA)
      JJ = KK
      L= J
      J1 = J+1
      DO 40 K=J1,NY1
      JJ = JJ + L
      L = L + 1
      SUM = DELTA*RMAT(JJ)
      DO 35 I=1,ROWS
   35 SUM = SUM + SMAT(NP6+I,NP6+J)*SMAT(NP6+I,NP6+K)
      IF(SUM.EQ.ZERO) GO TO 40
      SUM = SUM*BETA
      RMAT(JJ) = RMAT(JJ) + SUM*DELTA
      DO 36 I=1,ROWS
   36 SMAT(NP6+I,NP6+K) = SMAT(NP6+I,NP6+K) + SUM*SMAT(NP6+I,NP6+J)
   40 CONTINUE
  500 KK=KK+J+1
C
C  CALCULATE DPSOS******
C  ..
      NP61 = NP6+1
      NN = NP61 + ROWS
      DELTA = ZERO
      DO 550 I=NP61,NN
 550  DELTA = DELTA + SMAT(I,NCOLA1) * SMAT(I,NCOLA1)
C
      DPSOS = DSQRT (DPSOS*DPSOS + DELTA)
C
      RETURN
      END


c---------------------------------------------------------------------
c---------------------------------------------------------------------

       subroutine error_norm(rms, u, nx, nxmax, ny, nz)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c this function computes the norm of the difference between the
c computed solution and the exact solution
c---------------------------------------------------------------------

       include 'header.h'

       integer nx, nxmax, ny, nz
       double precision u(5,0:nxmax-1,0:ny-1,0:nz-1)

       integer i, j, k, m
       double precision xi, eta, zeta, u_exact(5), rms(5), add
       double precision rms_loc(5)

       do    m = 1, 5
          rms(m) = 0.0d0
       end do

!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(rms_loc,add,m,u_exact,xi,i,eta,
!$OMP& j,zeta,k)
!$OMP&  SHARED(dnxm1,nx,dnym1,ny,dnzm1,nz)
       do m=1,5
          rms_loc(m)=0.0d0
       enddo
!$OMP DO
       do   k = 0, nz-1
          zeta = dble(k) * dnzm1
          do   j = 0, ny-1
             eta = dble(j) * dnym1
             do   i = 0, nx-1
                xi = dble(i) * dnxm1
                call exact_solution(xi, eta, zeta, u_exact)

                do   m = 1, 5
                   add = u(m,i,j,k)-u_exact(m)
                   rms_loc(m) = rms_loc(m) + add*add
                end do
             end do
          end do
       end do
!$OMP END DO nowait
       do m=1,5
!$OMP ATOMIC
          rms(m)=rms(m)+rms_loc(m)
       enddo
!$OMP END PARALLEL

       do    m = 1, 5
          rms(m) = rms(m) / (dble(nz-2)*dble(ny-2)*dble(nx-2))
          rms(m) = dsqrt(rms(m))
       end do

       return
       end

       subroutine rhs_norm(rms, rhs, nx, nxmax, ny, nz)

       include 'header.h'

       integer nx, nxmax, ny, nz
       double precision rhs(5,0:nxmax-1,0:ny-1,0:nz-1)

       integer i, j, k, m
       double precision rms(5), add
       double precision rms_loc(5)

       do   m = 1, 5
          rms(m) = 0.0d0
       end do

!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(rms_loc,add,m,i,j,k)
!$OMP&  SHARED(nx,ny,nz)
       do m=1,5
          rms_loc(m)=0.0d0
       enddo
!$OMP DO
       do k = 1, nz-2
          do j = 1, ny-2
             do i = 1, nx-2
               do m = 1, 5
                  add = rhs(m,i,j,k)
                  rms_loc(m) = rms_loc(m) + add*add
               end do
             end do
          end do
       end do
!$OMP END DO nowait
       do m=1,5
!$OMP ATOMIC
          rms(m)=rms(m)+rms_loc(m)
       enddo
!$OMP END PARALLEL

       do   m = 1, 5
          rms(m) = rms(m) / (dble(nz-2)*dble(ny-2)*dble(nx-2))
          rms(m) = dsqrt(rms(m))
       end do

       return
       end


! Calculate PDF of a scalar field.

subroutine calc_pdf(dist_mf, lo, hi, ng, num_bins, bin_edges, bin_count, bin_x_sum)
    use, intrinsic :: iso_c_binding
    implicit none

    integer(c_int), intent(in) :: lo(3), hi(3), ng
    real(c_double), intent(in) :: dist_mf (lo(1)-ng:hi(1)+ng, lo(2)-ng:hi(2)+ng, lo(3)-ng:hi(3)+ng, 1)
    integer(c_int), intent(in) :: num_bins
    real(c_double), intent(in) :: bin_edges (num_bins+1)

    integer(c_int), intent(out) :: bin_count (num_bins)
    real(c_double), intent(out) :: bin_x_sum (num_bins)

    real(c_double) :: x_min, x_max
    real(c_double) :: xi

    integer(c_int) :: i, j, k
    integer(c_int) :: bin_index, jj

    x_min = minval(bin_edges)
    x_max = maxval(bin_edges)

    bin_count (:) = 0
    bin_x_sum (:) = 0.0d0

    do k = lo(3), hi(3)
      do j = lo(2), hi(2)
        do i = lo(1), hi(1)

          xi = dist_mf(i, j, k, 1)
          if (xi < x_min .or. xi > x_max) cycle

          ! Find the bin each value belongs in.
          bin_index = -1
          do jj = 1, num_bins
            if (xi >= bin_edges(jj) .and. xi < bin_edges(jj+1)) then
                bin_index = jj
                exit
            end if
          end do
          ! If value exactly equals the largest bin edge, put it in the largest bin.
          if (bin_index == -1) bin_index = num_bins

          bin_count (bin_index) = bin_count (bin_index) + 1
          bin_x_sum (bin_index) = bin_x_sum (bin_index) + xi

        end do
      end do
    end do

end subroutine calc_pdf


PROGRAM F052

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER, PARAMETER :: NX    = 6
    INTEGER, PARAMETER :: N_MAX = 10

    CHARACTER (LEN=N_MAX), DIMENSION(NX) :: NUM_NX_STR
    CHARACTER (LEN=N_MAX)                :: DIGITS_SET_1, DIGITS_SET_2

    LOGICAL   :: SAME_DIGITS;

    INTEGER   :: N      = 6;
    INTEGER   :: NUM_1X = 125875;

    INTEGER   :: K, L, NUM_NX, NUM_MAX, TEMP_INDEX

    DO WHILE (N /= N_MAX)

        NUM_MAX = FLOOR(5.0 * (10.0 ** (N - 1)) / 3.0);

        DO WHILE (NUM_1X <= NUM_MAX)

            NUM_NX     = 0
            NUM_NX_STR = ACHAR(0)

            DIGITS_SET_1 = REPEAT("0", N_MAX)

            DO K = 1, NX

                NUM_NX = NUM_NX + NUM_1X
                WRITE(NUM_NX_STR(K)(1:N), '(I0)') NUM_NX

                DIGITS_SET_2 = REPEAT("0", N_MAX)

                DO L = 1, NX
                    TEMP_INDEX = IACHAR(NUM_NX_STR(K)(L:L)) - IACHAR('0') + 1
                    DIGITS_SET_2(TEMP_INDEX:TEMP_INDEX) = "1"
                END DO

                IF (K == 1) THEN
                    DIGITS_SET_1 = DIGITS_SET_2
                    CYCLE
                END IF

                SAME_DIGITS = .TRUE.

                IF (DIGITS_SET_1 /= DIGITS_SET_2) THEN
                    SAME_DIGITS = .FALSE.
                    EXIT
                END IF

            END DO

            IF (SAME_DIGITS) EXIT

            NUM_1X = NUM_1X + 1

        END DO

        IF (SAME_DIGITS) EXIT

        N = N + 1

    END DO

    PRINT ('(I0)'), NUM_1X

END PROGRAM F052


! Advent of Code 2021 : https://adventofcode.com/2021
! Puzzle for Day 07 part 02 :
! Build with:  gfortran -static-libgcc -o aoc_day07_p2 aoc_day07_p2.f90

program aoc_day07_p2

	use, intrinsic :: iso_fortran_env
	implicit none

	! Declare and set constants the AOC day and part
	integer,parameter :: day = 7, part = 2

	! Declare file related variables
	character(len=*), parameter :: filename = "day07-input.txt"
	character(len=*), parameter :: error1 = "file: '"//''//filename//''//"' not found"

	! Variables to track and manage the program
	integer :: total_crabs = 0
	integer :: total_positions = 0
	integer, allocatable :: crabArray(:)
	integer :: i

	! Output startup message
	call display_welcome(day,part)

	if (.NOT. file_exists(filename)) stop error1

	call get_crabs(filename, total_crabs, crabArray)

	total_positions = dim((maxval(crabArray)),(minval(crabArray)))
	if (minval(crabArray) .eq. 0) total_positions = total_positions + 1

	write(*,'(A,I0)') " » Total crabs in array: ",size(crabArray)
	write(*,'(A,I0)') " » Min crab position: ",minval(crabArray)
	write(*,'(A,I0)') " » Max crab position: ",maxval(crabArray)
	write(*,'(A,I0)') " » Number of potential postions: ",total_positions

	print *, ""
	write(*,'(A,I0)') " » Part 2: Fuel used is: ",minval((/(sum((abs(crabArray-i)**2+abs(crabArray-i))/2),i=0,maxval(crabArray))/))
	print *, ""

contains

	! Display the AoC puzzle day and part being resolved
	subroutine display_welcome(day,part)
		implicit none
		integer, intent(in) :: day,part
		print *,""
		write (*,'(A,I2.2,A,I2.2)') "AoC 2021 - solution for Day ",day," part ",part
		print *,""
	end subroutine display_welcome

	! Check input filename exists
	function file_exists(filename) result (exists)
		implicit none
		character(len=*), intent(in) :: filename
		logical :: exists
		inquire(file=filename, exist=exists)
	end function file_exists

    ! Read in the list of crabs positions from puzzle data source file
    subroutine get_crabs(filename, total_crabs, crabArray)
        character(len=*), intent(in) :: filename
        integer, intent(inout) :: total_crabs
        integer, allocatable, intent(inout) :: crabArray(:)
        integer :: fileunit, io
        character(len=1) :: A   ! account for ',' separator in in file

        open(newunit=fileunit, file=filename, action='read', position='rewind')

        total_crabs = 1  ! account for one more number than commas in file

        do
            read(fileunit,'(A)',advance="no",iostat=io) A
            if (io /= 0) exit
            if (A .EQ. ",") total_crabs = total_crabs + 1
        end do

        !print *, "File read total crab count: ",total_crabs

		rewind(fileunit)
		allocate(crabArray(total_crabs))

		read(fileunit,*) crabArray

        close(fileunit)

    end subroutine get_crabs

end program aoc_day07_p2


    Program zgbequ_example

!     ZGBEQU Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: zdscal
      Use lapack_example_aux, Only: nagf_blas_zddscl, &
        nagf_file_print_matrix_complex_band
      Use lapack_interfaces, Only: zgbequ
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: one = 1.0_dp
      Real (Kind=dp), Parameter :: thresh = 0.1_dp
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: amax, big, colcnd, rowcnd, small
      Integer :: i, i0, i1, ifail, ilen, info, j, k, kl, ku, ldab, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: ab(:, :)
      Real (Kind=dp), Allocatable :: c(:), r(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: epsilon, max, min, radix, real, tiny
!     .. Executable Statements ..
      Write (nout, *) 'ZGBEQU Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n, kl, ku
      ldab = kl + ku + 1
      Allocate (ab(ldab,n), c(n), r(n))

!     Read the band matrix A from data file

      k = ku + 1
      Read (nin, *)((ab(k+i-j,j),j=max(i-kl,1),min(i+ku,n)), i=1, n)

!     Print the matrix A

!     ifail: behaviour on error exit
!             =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_complex_band(n, n, kl, ku, ab, ldab, &
        'Matrix A', ifail)

      Write (nout, *)

!     Compute row and column scaling factors

      Call zgbequ(n, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd, amax, info)

      If (info>0) Then
        If (info<=n) Then
          Write (nout, 100) 'Row ', info, ' of A is exactly zero'
        Else
          Write (nout, 100) 'Column ', info - n, ' of A is exactly zero'
        End If
      Else

!       Print ROWCND, COLCND, AMAX and the scale factors

        Write (nout, 110) 'ROWCND =', rowcnd, ', COLCND =', colcnd, &
          ', AMAX =', amax
        Write (nout, *)
        Write (nout, *) 'Row scale factors'
        Write (nout, 120) r(1:n)
        Write (nout, *)
        Write (nout, *) 'Column scale factors'
        Write (nout, 120) c(1:n)
        Write (nout, *)
        Flush (nout)

!       Compute values close to underflow and overflow

        small = tiny(1.0E0_dp)/(epsilon(1.0E0_dp)*real(radix(1.0E0_dp),kind=dp &
          ))
        big = one/small
        If ((rowcnd>=thresh) .And. (amax>=small) .And. (amax<=big)) Then
          If (colcnd<thresh) Then

!           Just column scale A
            Do j = 1, n
              i1 = 1 + max(1, j-ku) - (j-ku)
              ilen = min(n, j+kl) - max(1, j-ku) + 1
              Call zdscal(ilen, c(j), ab(i1,j), 1)
            End Do

          End If
        Else If (colcnd>=thresh) Then

!         Just row scale A
          Do j = 1, n
            i0 = max(1, j-ku)
            i1 = 1 + i0 - (j-ku)
            ilen = min(n, j+kl) - i0 + 1
            Call nagf_blas_zddscl(ilen, r(i0), 1, ab(i1,j), 1)
          End Do

        Else

!         Row and column scale A
          Do j = 1, n
            i0 = max(1, j-ku)
            i1 = 1 + i0 - (j-ku)
            ilen = min(n, j+kl) - i0 + 1
            Call zdscal(ilen, c(j), ab(i1,j), 1)
            Call nagf_blas_zddscl(ilen, r(i0), 1, ab(i1,j), 1)
          End Do

        End If

!       Print the scaled matrix
        ifail = 0
        Call nagf_file_print_matrix_complex_band(n, n, kl, ku, ab, ldab, &
          'Scaled matrix', ifail)

      End If

100   Format (1X, A, I4, A)
110   Format (1X, 3(A,1P,E8.1))
120   Format ((1X,1P,7E11.2))
    End Program


!! Copyright (C) 2008 Pavel Sakov
!!
!! This file is part of EnKF-Matlab. EnKF-Matlab is a free software. See
!! LICENSE for details.

! File:           calc.f90
!
! Created:        31/08/2007
!
! Last modified:  08/02/2008
!
! Author:         Pavel Sakov
!                 CSIRO Marine and Atmospheric Research
!                 NERSC
!
! Purpose:        Fortran code for QG model. Mathematical utilities.
!
! Description:
!
! Revisions:

module calc_mod

  use utils_mod
  implicit none

  public arakawa, laplacian

contains

  subroutine arakawa(A, B, dx, dy, JACOBIAN)
    real(8), dimension(:, :), intent(in) :: A, B
    real(8), intent(in) :: dx, dy
    real(8), dimension(:, :), intent(inout) :: JACOBIAN
    integer m1, n1
    integer i, j

    m1 = size(A, 1) - 1
    n1 = size(A, 2) - 1

    do j = 2, m1
       do i = 2, n1
          JACOBIAN(j, i) = (A(j - 1, i) - A(j, i - 1)) * B(j - 1, i - 1) +&
               (A(j - 1, i - 1) + A(j - 1, i) - A(j + 1,i - 1) -A(j + 1, i)) * B(j, i - 1) +&
               (A(j, i - 1) - A(j + 1, i)) * B(j + 1,i - 1) +&
               (A(j - 1,i + 1) + A(j, i + 1) - A(j - 1,i - 1) - A(j, i - 1)) * B(j - 1, i) +&
               (A(j, i - 1) + A(j + 1, i - 1) - A(j, i + 1) - A(j + 1, i + 1)) * B(j + 1, i) +&
               (A(j, i + 1) - A(j - 1, i)) * B(j - 1,i + 1) +&
               (A(j + 1, i) + A(j + 1,i + 1) - A(j - 1, i) - A(j - 1,i + 1)) * B(j, i + 1) +&
               (A(j + 1, i) - A(j, i + 1)) * B(j + 1, i + 1)
       end do
    end do
    JACOBIAN(2 : m1, 2 : n1) = JACOBIAN(2 : m1, 2 : n1) / (12.0d0 * dx * dy)
  end subroutine arakawa

  subroutine laplacian(A, dx, dy, L)
    real(8), intent(in), dimension(:, :) :: A
    real(8), intent(in) :: dx, dy
    real(8), dimension(:, :), intent(inout) :: L
    real(8) :: dx2, dy2
    integer m, n

    m = size(A, 1)
    n = size(A, 2)

    dx2 = dx * dx
    dy2 = dy * dy

    L(2 : m - 1, 2 : n - 1) =&
         (A(1 : m - 2, 2 : n - 1) + A(3 : m, 2 : n - 1)) / dx2&
         + (A(2 : m - 1, 1 : n - 2) + A(2 : m - 1, 3 : n)) / dy2&
         - A(2 : m - 1, 2 : n - 1) * (2.0d0 / dx2 + 2.0d0 / dy2)

    ! L = 0 on the boundary
    !
    L(1, :) = 0.0d0
    L(m, :) = 0.0d0
    L(:, 1) = 0.0d0
    L(:, n) = 0.0d0
  end subroutine laplacian

end module calc_mod


!##############################################################################
!# ****************************************************************************
!# <name> renum2d </name>
!# ****************************************************************************
!#
!# <purpose>
!# This program uses a simple test the equation
!#
!#              - Laplace(u) = f
!#
!# for a scalar function u to test the MFLOP rate in matrix-vector
!# multiplication and the speed of different solvers on different levels.
!# </purpose>
!##############################################################################

program poisson

  use renum2d_test1
  use renum2d_test2

  implicit none

  ! local variables
  character(len=SYS_STRLEN) :: slogdir,slogfile,sdatafile
  type(t_parlist) :: rparlist
  logical :: bexists

  ! The very first thing in every application:
  ! Initialise system-wide settings:

  call sys_init()

  ! Initialise the output system.
  !
  ! Normally, we write all the output to the screen and to a file
  ! './log/output.txt'.
  ! In the case that environment variables "$logdir"/"$resultsfile" exists,
  ! we write all the output to that file. This can be used e.g. in
  ! regression tests to compare results to reference results.
  if (sys_getenv_string('LOGDIR',slogdir) .and. &
      sys_getenv_string('RESULTFILE',slogfile)) then
    call output_init (trim(slogdir)//'/'//trim(slogfile))
  else
    call output_init ('./log/output.txt')
  end if

  ! The very second thing in every program:
  ! Initialise the FEAT 2.0 storage management:
  call storage_init(999, 100)

  ! Print the configuration
  call sys_getcommandLineArg(1,sdatafile,sdefault='./data/renum.dat')
  inquire(file=sdatafile,exist=bexists)
  if (.not. bexists) then
    call output_line ('Data file not found: '//trim(sdatafile), OU_CLASS_ERROR)
    call sys_halt()
  end if

  call parlst_init(rparlist)
  call parlst_readfromfile (rparlist, sdatafile)
  call parlst_info(rparlist)
  call parlst_done(rparlist)

  !!!!!!! poisson2d_0_simple = MFLOP-Rate test !!!!!!!!

  ! Call the problem to solve. Poisson 2D method 1 - simple:
  call output_lbrk ()
  call output_line ('Calculating Performance-test MatVec')
  call output_line ('-----------------------------------')
  call renum2d_matvec_mfloptest

  !!!!!!! poisson2d_0_simple = Solver test vor different renumbering strategies  !!!!!!!!

  ! Call the problem to solve. Poisson 2D method 1 - multigrid:
  call output_lbrk ()
  call output_line ('Calculating Performance-test SolverTest')
  call output_line ('---------------------------------------')
  call renum2d_solvertest

  ! Print out heap statistics - just to check if everything
  ! is cleaned up.
  ! This should display 'Handles in use=0' and 'Memory in use=0'!
  call output_lbrk ()
  call storage_info(.true.)

  ! Clean up the storage management, finish
  call storage_done()

end program


      subroutine CELLTOEDGE(
     &           cellData
     &           ,icellDatalo0
     &           ,icellDatahi0
     &           ,edgeData
     &           ,iedgeDatalo0
     &           ,iedgeDatahi0
     &           ,iedgeBoxlo0
     &           ,iedgeBoxhi0
     &           ,dir
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer CHF_ID(0:5,0:5)
      data CHF_ID/ 1,0,0,0,0,0 ,0,1,0,0,0,0 ,0,0,1,0,0,0 ,0,0,0,1,0,0 ,0
     &,0,0,0,1,0 ,0,0,0,0,0,1 /
      integer icellDatalo0
      integer icellDatahi0
      REAL*8 cellData(
     &           icellDatalo0:icellDatahi0)
      integer iedgeDatalo0
      integer iedgeDatahi0
      REAL*8 edgeData(
     &           iedgeDatalo0:iedgeDatahi0)
      integer iedgeBoxlo0
      integer iedgeBoxhi0
      integer dir
      integer i
      integer ii
      do i = iedgeBoxlo0,iedgeBoxhi0
        ii = i-CHF_ID(0,dir)
        edgeData(i) = (0.500d0)*(
     &           cellData(ii)
     &         + cellData(i) )
      enddo
        return
        end


! This file is part of fortran_quaternion
! Author: Pierre de Buyl http://pdebuyl.be/
! License: BSD 3-clause

program test_base
  use quaternion
  use tester
  implicit none

  type(tester_t) :: test
  double precision :: q(4)
  double precision :: v(3)
  double precision :: s

  call test%init()

  write(*,*) 'Testing the conversion between scalars, vectors and quaternions'

  v = [10, 11, 12]
  q = qnew(v=v)
  call test% assert_close(v, qvector(q))
  call test% assert_close(0.d0, qscalar(q))

  s = 1.201d0
  q = qnew(s=s)
  call test% assert_close([0.d0, 0.d0, 0.d0], qvector(q))
  call test% assert_close(s, qscalar(q))

  s = -1234.56d0
  v = [0.d0, 100.d0, 5.d0]
  q = qnew(s=s, v=v)
  call test% assert_close(v, qvector(q))
  call test% assert_close(s, qscalar(q))

  s = 0
  v = 0
  q = qnew()
  call test% assert_close(v, qvector(q))
  call test% assert_close(0.d0, qscalar(q))

  call test%print()

end program test_base


real function mul(a,b)
  real :: a, b
  mul = a * b
end function mul

real function sqr(x)
  != unit m :: x
  real :: x, y

  y = mul(x,x)
  sqr = y
end function sqr

program main
  real :: a
  a = sqr(2)
end program main


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   kar :       The Von Karman swirling flow
!----------------------------------------------------------------------
!----------------------------------------------------------------------
      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

      DOUBLE PRECISION U1,U2,U3,U4,U5,GAMMA,ZINF

       U1=U(1)
       U2=U(2)
       U3=U(3)
       U4=U(4)
       U5=U(5)

       GAMMA=PAR(1)
       ZINF =PAR(3)

       F(1)=ZINF*U2
       F(2)=ZINF*U3
       F(3)=ZINF*( - 2*GAMMA*U4 + U2*U2 - 2*U1*U3 - U4*U4)
       F(4)=ZINF*U5
       F(5)=ZINF*(2*GAMMA*U2 + 2*U2*U4 - 2*U1*U5)

      END SUBROUTINE FUNC

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T

      DOUBLE PRECISION GAMMA,FINF,ZINF

       GAMMA=1.
       FINF =0.
       ZINF =500.

       PAR(1)=GAMMA
       PAR(2)=-FINF
       PAR(3)=ZINF

       U(1)=0.
       U(2)=0.
       U(3)=0.
       U(4)=0.
       U(5)=0.

      END SUBROUTINE STPNT

      SUBROUTINE BCND(NDIM,PAR,ICP,NBC,U0,U1,F,IJAC,DBC)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), NBC, IJAC
      DOUBLE PRECISION, INTENT(IN) :: PAR(*), U0(NDIM), U1(NDIM)
      DOUBLE PRECISION, INTENT(OUT) :: F(NBC)
      DOUBLE PRECISION, INTENT(INOUT) :: DBC(NBC,*)

      DOUBLE PRECISION GAMMA,FINF,C,A,B

       GAMMA=PAR(1)
       FINF=-PAR(2)

       C=SQRT(FINF**4 + 4*GAMMA**2)
       A=SQRT(C + FINF**2) / SQRT(2.d0)
       B=SQRT(C - FINF**2) / SQRT(2.d0)

       F(1)=U0(1)
       F(2)=U0(2)
       F(3)=U0(4)-1+GAMMA
       F(4)=(FINF+A)*U1(2) + U1(3) - GAMMA*U1(4)/A
       F(5)=A*B**2*U1(2)/GAMMA + (FINF+A)*U1(4) + U1(5)
       F(6)=U1(1)-FINF

      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


!---------------------------------------------------------
!
!  Parallel Diagnostic for Computing Turbelent Spectra
!
!  This version uses P3FFT package which peforms
!  3D parallel Fourier transforms.  Note that the decomposion
!  must be in the y and z direction (not in x)
!--------------------------------------------------------

module MPI
  include "mpif.h"
  integer myid,numprocs,ierr
  integer master
  integer nfiles
  parameter(nfiles=1)
  integer sizes(3), subsizes(3), starts(3)
  integer fileinfo, ierror, fh(nfiles), filetype, status(MPI_STATUS_SIZE), output_format
  integer(kind=MPI_OFFSET_KIND) :: disp, offset
  parameter(master=0)
end module MPI

program turbulence
  use mpi
  use p3dfft
  implicit none
  character(50) fname,sname,time
  character(4), allocatable, dimension(:) ::  bname
  real(kind=4) xmax,ymax,zmax,pi,a0,a1,a2,alpha,window,dkx,dky,dkz,kperp,dk,kmax
  parameter(pi=3.141592654)
  integer(kind=4)nxt,nyt,nzt,ntot,i,j,k,n,i0,j0,k0,num,nbase,ip
  real(kind=4), allocatable, dimension(:,:) ::  lper,perp
  real(kind=4), allocatable, dimension(:) ::  lpar
  real(kind=4), allocatable, dimension(:,:) :: para,eperp
  logical found

! p3fft stuff

  integer istart(3),iend(3),isize(3)
  integer fstart(3),fend(3),fsize(3)
  logical overwrite
  integer(kind=4) topology(2)
  integer, parameter :: mytype=4
  real(mytype), allocatable, dimension(:,:,:) :: field
  complex(mytype), allocatable, dimension(:,:,:) :: local

! Initialize MPI

  call MPI_INIT(ierr)
  call MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)
  call MPI_COMM_SIZE(MPI_COMM_WORLD, numprocs, ierr)

! Displacement and offset

  disp = 0
  offset = 0

! Time slice

  time='14400'

! Variables to transform

  nbase = 3
  allocate(bname(nbase))
  fname="b"
  bname(1) = 'bx'
  bname(2) = 'by'
  bname(3) = 'bz'

!  fname="U"
!  bname(1) = 'uix'
!  bname(2) = 'uiy'
!  bname(3) = 'uiz'

! Read array sizes from file

  if (myid == master) then
     open(unit=10,file='data/info',status='unknown',form='unformatted')
     read(10)nxt,nyt,nzt
     read(10)xmax,ymax,zmax
     print *,"nxt=",nxt,"  xmax=",xmax
     print *,"nyt=",nyt,"  ymax=",ymax
     print *,"nzt=",nzt,"  zmax=",zmax
  endif
  call MPI_BCAST(nxt,1,MPI_INTEGER,master,MPI_COMM_WORLD,ierr)
  call MPI_BCAST(nyt,1,MPI_INTEGER,master,MPI_COMM_WORLD,ierr)
  call MPI_BCAST(nzt,1,MPI_INTEGER,master,MPI_COMM_WORLD,ierr)
  call MPI_BCAST(xmax,1,MPI_REAL,master,MPI_COMM_WORLD,ierr)
  call MPI_BCAST(ymax,1,MPI_REAL,master,MPI_COMM_WORLD,ierr)
  call MPI_BCAST(zmax,1,MPI_REAL,master,MPI_COMM_WORLD,ierr)

! Alternatively - can specify these manually

!  xmax = 720.0
!  ymax = 720.0
!  zmax = 240.0
!  nxt = 3072
!  nyt = 3072
!  nzt = 1024

! Topology for parallel processing

  topology(1)=8  ! y-direction
  topology(2)=8  ! z-direction

! Is the requested topology consistent ?

  if ( topology(1)*topology(2) .ne. numprocs) then
     print *, " ** Inconsistent Topology --> Terminating ***"
     call MPI_FINALIZE(ierr)
     stop
  endif

! Initialize P3DFFT

 if (myid == master ) print *,"Initializing P3DFFT"
 overwrite=.False.

! Syntax for 2.6.1 of P3DFFT

 call p3dfft_setup(topology,nxt,nyt,nzt,MPI_COMM_WORLD)
! Syntax for 2.4 of P3DFFT
! call p3dfft_setup(topology,nxt,nyt,nzt,overwrite)

 call p3dfft_get_dims(istart,iend,isize,1)
 call p3dfft_get_dims(fstart,fend,fsize,2)

 if (myid == master) then
    print *,"------------------------------------------------------"
    print *,"Decomposition of real data"
    print *,"istart=",istart(1)," iend=",iend(1)," isize=",isize(1)
    print *,"istart=",istart(2)," iend=",iend(2)," isize=",isize(2)
    print *,"istart=",istart(3)," iend=",iend(3)," isize=",isize(3)
    print *
    print *,"Decomposition of FFT data"
    print *,"fstart=",fstart(1)," fend=",fend(1)," fsize=",fsize(1)
    print *,"fstart=",fstart(2)," fend=",fend(2)," fsize=",fsize(2)
    print *,"fstart=",fstart(3)," fend=",fend(3)," fsize=",fsize(3)
    print *,"------------------------------------------------------"
 endif

 call MPI_BARRIER(MPI_COMM_WORLD,ierr)

! if (myid == numprocs-1) then
!    print *,"------------------ LAST NODE ---------------------------"
!    print *,"istart=",istart(1)," iend=",iend(1)," isize=",isize(1)
!    print *,"istart=",istart(2)," iend=",iend(2)," isize=",isize(2)
!    print *,"istart=",istart(3)," iend=",iend(3)," isize=",isize(3)
!    print *
!    print *,"fstart=",fstart(1)," fend=",fend(1)," fsize=",fsize(1)
!    print *,"fstart=",fstart(2)," fend=",fend(2)," fsize=",fsize(2)
!    print *,"fstart=",fstart(3)," fend=",fend(3)," fsize=",fsize(3)
!    print *,"------------------------------------------------------"
! endif

! Allocate storage space for calculations

 if (myid .eq. master) print *, "Allocating storage arrays"
 allocate(field(isize(1),isize(2),isize(3)))
 allocate(local(fsize(1),fsize(2),fsize(3)))

! allocate(lpar(nxt/2+1))
! allocate(para(nbase,nxt/2+1))
! allocate(lper(nyt,nzt))
! allocate(perp(nyt,nzt))

 allocate(lpar(nyt))
 allocate(para(nbase,nyt))
 allocate(lper(nxt/2+1,nzt))
 allocate(perp(nxt/2+1,nzt))

! Initialize variables

  para=0.0
  perp=0.0
  lpar=0.0
  lper=0.0

! Size of the global matrix

  sizes(1) = nxt
  sizes(2) = nyt
  sizes(3) = nzt

! size of the chunck seen by each process

  subsizes(1) = isize(1)
  subsizes(2) = isize(2)
  subsizes(3) = isize(3)

! where each chunck starts

  starts(1) = istart(1)-1
  starts(2) = istart(2)-1
  starts(3) = istart(3)-1

! Grid for reduced kperp calculation

  dkx = 2.0*pi/xmax
  dky = 2.0*pi/ymax
  dkz = 2.0*pi/zmax
  num = nzt/2
  kmax = pi*real(nzt)/zmax
  dk = kmax/real(num)
  allocate(eperp(nbase,num))
  eperp=0.0

! Loop over base names

  call MPI_BARRIER(MPI_COMM_WORLD,ierr)
  if (myid .eq.0) print *,"Start of main loop"

  do n=1,nbase

!  Open the data file
     write(sname,"(A,A,A,A,A)")"data/",trim(bname(n)),"_",trim(time),".gda"
     inquire(file=trim(sname),exist=found)
     if (.not. found) then
        print *,trim(sname),"  does not exist --> Terminating"
        call MPI_FINALIZE(ierr)
        stop
     endif
     if (myid .eq. 0 ) print *,"Reading file -->",trim(sname)
     call MPI_TYPE_CREATE_SUBARRAY(3,sizes,subsizes,starts, MPI_ORDER_FORTRAN, MPI_REAL4, filetype, ierror)
     call MPI_TYPE_COMMIT(filetype, ierror)
     call MPI_INFO_CREATE(fileinfo,ierror)
     call MPI_FILE_OPEN(MPI_COMM_WORLD, trim(sname), MPI_MODE_RDONLY, fileinfo, fh, ierror)
     call MPI_FILE_SET_VIEW(fh,disp, MPI_REAL4, filetype, 'native', MPI_INFO_NULL, ierror)

! Read data and close file

     ntot = isize(1)*isize(2)*isize(3)
     call MPI_FILE_READ_AT_ALL(fh, offset, field, ntot, MPI_REAL4, status, ierror)
     call MPI_FILE_CLOSE(fh, ierror)
     if (myid .eq. 0 ) print *,"Finished Reading data"

! Subtract off equilibrium By field

     if ( n== 2) then
        if (myid .eq. 0 ) print *,"Remove equilibrium By"
        field = field - 0.46
     endif

! Apply Blackman window in z-direction

        if (myid .eq. 0 ) print *,"Apply Blackman window in z-direction"
        alpha=0.16
        a0 = (1.0-alpha)/2.0
        a1=0.5
        a2=alpha/2.0
        do k=1,isize(3)
           j = k+istart(3)-1
           window = a0 -a1*cos(2.0*pi*j/(nzt-1))+a2*cos(4*pi*j/(nzt-1))
           field(:,:,k) = window*field(:,:,k)
        enddo

! Take 3D transform

     if (myid .eq. 0 ) print *,"Taking 3D Fourier Transform"

!  This is the syntax for version 2.6.1 of P3FFT
     call p3dfft_ftran_r2c(field,local,"fff")

!  This is the syntax for version 2.4 of P3FFT
!     call p3dfft_ftran_r2c(field,local)

     local = local/real(nxt*nyt*nzt)

! Compute reduced power spectrums on each node

     lpar(:) = 0.0
     lper(:,:) = 0.0
     do i=1,fsize(1)
        do j=1,fsize(2)
           do k=1,fsize(3)
              i0 = fstart(1)+i-1
              j0 = fstart(2)+j-1
              k0 = fstart(3)+k-1
              lpar(j0) = lpar(j0) + abs(local(i,j,k))**2
              lper(i0,k0) = lper(i0,k0) + abs(local(i,j,k))**2
           enddo
        enddo
     enddo

! Sum across nodes and output global power spectrum on master

     call MPI_REDUCE(lpar,para(n,:),nyt,MPI_REAL,MPI_SUM,master,MPI_COMM_WORLD,ierr)
     call MPI_REDUCE(lper,perp,(nxt/2+1)*nzt,MPI_REAL,MPI_SUM,master,MPI_COMM_WORLD,ierr)

! Compute reduced perp spectrum

     if (myid .eq. master) then

        do i = 1,nxt/2+1
           do k = 1,nzt/2
              kperp =sqrt((dkx*real(i-1))**2 + (dkz*real(k-1))**2)
              ip = int(kperp/dk)+1
              if (ip .le. num ) eperp(n,ip) = eperp(n,ip) + (perp(i,k) + perp(i,nzt-k+1))
           enddo
        enddo
     endif

! End of loop over base quantities

  enddo

  if (myid .eq. 0) then

     write(sname,"(A,A,A)")trim(fname),trim(time),".par"
     open(unit=50,file=trim(sname),status='unknown')
     do i=1,nyt/2
        write(50,66)2.0*pi*real(i)/ymax,(para(1,i)+para(1,nyt+1-i)),(para(2,i)+para(2,nyt+1-i)),  &
             (para(3,i)+para(3,nyt+1-i)), &
             (para(1,i)+para(2,i)+para(3,i)+para(1,nyt+1-i)+para(2,nyt+1-i)+para(3,nyt+1-i))
     enddo
     close(50)

     write(sname,"(A,A,A)")trim(fname),trim(time),".per"
     open(unit=50,file=trim(sname),status='unknown')
     do i=1,num
        kperp = dk*real(i)
        write(50,66)kperp,(eperp(1,i)),(eperp(2,i)),(eperp(3,i)),(eperp(1,i)+eperp(2,i)+eperp(3,i))
     enddo
     close(50)

  endif

! Format statements

 66 format(5(1x,1pe13.5))

! End of Program

  call MPI_FINALIZE(ierr)

end program turbulence


!
! fcc.f90
!
! Copyright 2016 Bruno S <bruno@oac.unc.edu.ar>
!
! 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; either version 2 of the License, or
! (at your option) any later version.
!
! 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.
!
program fcc

use precision, pr=>dp

implicit none
integer                         :: i, j, k
integer                         :: ix, iy, iz
integer, parameter              :: n=256
real(pr), allocatable           :: part(:)
real(pr), parameter             :: a=1._pr

allocate(part(1:3*n))

36 format(I12, 2X, 3(F8.4, 2X))

! cubica simple de n/4
i = 1
do ix = 0, 3, 1
    do iy = 0, 3, 1
        do iz = 0, 3, 1

            if (i > n) exit

            ! coloco una cubica
            part(3*i - 2) = ix*a
            part(3*i - 1) = iy*a
            part(3*i)     = iz*a

            ! coloco tres mas para el fcc
            i = i + 1
            part(3*i - 2) = ix + a/2.
            part(3*i - 1) = iy + a/2.
            part(3*i)     = iz

            i = i + 1
            part(3*i - 2) = ix + a/2.
            part(3*i - 1) = iy
            part(3*i)     = iz + a/2.

            i = i + 1
            part(3*i - 2) = ix
            part(3*i - 1) = iy + a/2.
            part(3*i)     = iz + a/2.

            i = i + 1
        end do
    end do
end do

open(unit=10, file='fcc_part.dat', status='unknown')
!write(10, *) '#  i  x  y  z'
do i = 1, n
    write(10, 36) i, part(i*3-2), part(i*3-1), part(i*3)
end do

end program