C**************************************************************************
C      FFTPACK: Available at http://www.scd.ucar.edu/softlib/mathlib.html
C
C   ***NOTE (C.T.) *** this is a subset of FFTPACK, which only includes
C            the routines for the complex FFT (forward & inverse).
C
C Modified: November 1999 by Arjan van Dijk to include IMPLICIT NONE and
C           to convert all routines to DOUBLE precision.
C**************************************************************************

C      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C      *                                          *
C      *                        FFTPACK             *
C      *                                          *
C      *     A package of Fortran subprograms for calculating          *
C      *     fast Fourier transforms for both complex and real         *
C      *      periodic sequences and certain other symmetric           *
C      *             sequences that are listed below            *
C      *               (Version 4.1 November 1988)                *
C      *                          by                    *
C      *                     Paul Swarztrauber                   *
C      *                          of                    *
C      *         The National Center for Atmospheric Research         *
C      *               Boulder, Colorado  (80307)  U.S.A.           *
C      *                  which is sponsored by                  *
C      *              the National Science Foundation          *
C      *                                          *
C      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C  Any source code available through this distribution interface at NCAR
C  is free of charge, but there is no guarantee.
C
C FFTPACK breaks the FORTRAN 77 ANSI Standard
C by passing REAL arrays to subroutines and using the arrays within
C the subroutines as DOUBLE PRECISION or other types.  This infraction
C may cause data alignment problems when the source code is compiled
C and loaded in an executable.

C****************************************************************************
C     SUBROUTINE CFFTI(N,WSAVE)
C
C     SUBROUTINE CFFTI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN
C     BOTH CFFTF AND CFFTB. THE PRIME FACTORIZATION OF N TOGETHER WITH
C     A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND
C     STORED IN WSAVE.
C
C     INPUT PARAMETER
C
C     N       THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED
C
C     OUTPUT PARAMETER
C
C     WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 4*N+15
C             THE SAME WORK ARRAY CAN BE USED FOR BOTH CFFTF AND CFFTB
C             AS LONG AS N REMAINS UNCHANGED. DIFFERENT WSAVE ARRAYS
C             ARE REQUIRED FOR DIFFERENT VALUES OF N. THE CONTENTS OF
C             WSAVE MUST NOT BE CHANGED BETWEEN CALLS OF CFFTF OR CFFTB.
C
      SUBROUTINE CFFTI (N,WSAVE)
      IMPLICIT NONE
      INTEGER N,IW1,IW2
      DOUBLE PRECISION WSAVE
      DIMENSION       WSAVE(*)
C
      IF (N .EQ. 1) RETURN
      IW1 = N+N+1
      IW2 = IW1+N+N
      CALL CFFTI1 (N,WSAVE(IW1),WSAVE(IW2))
      RETURN
      END

C****************************************************************************
C     SUBROUTINE CFFTF(N,C,WSAVE)
C
C     SUBROUTINE CFFTF COMPUTES THE FORWARD COMPLEX DISCRETE FOURIER
C     TRANSFORM (THE FOURIER ANALYSIS). EQUIVALENTLY , CFFTF COMPUTES
C     THE FOURIER COEFFICIENTS OF A COMPLEX PERIODIC SEQUENCE.
C     THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER C.
C
C     THE TRANSFORM IS NOT NORMALIZED. TO OBTAIN A NORMALIZED TRANSFORM
C     THE OUTPUT MUST BE DIVIDED BY N. OTHERWISE A CALL OF CFFTF
C     FOLLOWED BY A CALL OF CFFTB WILL MULTIPLY THE SEQUENCE BY N.
C
C     THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE CFFTF MUST BE
C     INITIALIZED BY CALLING SUBROUTINE CFFTI(N,WSAVE).
C
C     INPUT PARAMETERS
C
C
C     N      THE LENGTH OF THE COMPLEX SEQUENCE C. THE METHOD IS
C            MORE EFFICIENT WHEN N IS THE PRODUCT OF SMALL PRIMES. N
C
C     C      A COMPLEX ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE
C
C     WSAVE   A REAL WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 4N+15
C             IN THE PROGRAM THAT CALLS CFFTF. THE WSAVE ARRAY MUST BE
C             INITIALIZED BY CALLING SUBROUTINE CFFTI(N,WSAVE) AND A
C             DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT
C             VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE
C             REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT
C             TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST.
C             THE SAME WSAVE ARRAY CAN BE USED BY CFFTF AND CFFTB.
C
C     OUTPUT PARAMETERS
C
C     C      FOR J=1,...,N
C
C              C(J)=THE SUM FROM K=1,...,N OF
C
C                    C(K)*EXP(-I*(J-1)*(K-1)*2*PI/N)
C
C                       WHERE I=SQRT(-1)
C
C     WSAVE   CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT BE
C             DESTROYED BETWEEN CALLS OF SUBROUTINE CFFTF OR CFFTB
C
      SUBROUTINE CFFTF (N,C,WSAVE)
      IMPLICIT NONE
      INTEGER N,IW1,IW2
      DOUBLE PRECISION C,WSAVE
      DIMENSION       C(*)       ,WSAVE(*)
C
      IF (N .EQ. 1) RETURN
      IW1 = N+N+1
      IW2 = IW1+N+N
      CALL CFFTF1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2))
      RETURN
      END

C****************************************************************************
C     SUBROUTINE CFFTB(N,C,WSAVE)
C
C     SUBROUTINE CFFTB COMPUTES THE BACKWARD COMPLEX DISCRETE FOURIER
C     TRANSFORM (THE FOURIER SYNTHESIS). EQUIVALENTLY , CFFTB COMPUTES
C     A COMPLEX PERIODIC SEQUENCE FROM ITS FOURIER COEFFICIENTS.
C     THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER C.
C
C     A CALL OF CFFTF FOLLOWED BY A CALL OF CFFTB WILL MULTIPLY THE
C     SEQUENCE BY N.
C
C     THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE CFFTB MUST BE
C     INITIALIZED BY CALLING SUBROUTINE CFFTI(N,WSAVE).
C
C     INPUT PARAMETERS
C
C
C     N      THE LENGTH OF THE COMPLEX SEQUENCE C. THE METHOD IS
C            MORE EFFICIENT WHEN N IS THE PRODUCT OF SMALL PRIMES.
C
C     C      A COMPLEX ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE
C
C     WSAVE   A REAL WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 4N+15
C             IN THE PROGRAM THAT CALLS CFFTB. THE WSAVE ARRAY MUST BE
C             INITIALIZED BY CALLING SUBROUTINE CFFTI(N,WSAVE) AND A
C             DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT
C             VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE
C             REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT
C             TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST.
C             THE SAME WSAVE ARRAY CAN BE USED BY CFFTF AND CFFTB.
C
C     OUTPUT PARAMETERS
C
C     C      FOR J=1,...,N
C
C              C(J)=THE SUM FROM K=1,...,N OF
C
C                    C(K)*EXP(I*(J-1)*(K-1)*2*PI/N)
C
C                       WHERE I=SQRT(-1)
C
C     WSAVE   CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT BE
C             DESTROYED BETWEEN CALLS OF SUBROUTINE CFFTF OR CFFTB
C
      SUBROUTINE CFFTB (N,C,WSAVE)
      IMPLICIT NONE
      INTEGER N,IW1,IW2
      DOUBLE PRECISION C,WSAVE
      DIMENSION       C(*)       ,WSAVE(*)
C
      IF (N .EQ. 1) RETURN
      IW1 = N+N+1
      IW2 = IW1+N+N
      CALL CFFTB1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2))
      RETURN
      END

C****************************************************************************
      SUBROUTINE CFFTI1 (N,WA,WIFAC)
      IMPLICIT NONE
      INTEGER N,NTRYH,NL,NF,J,NTRY,NQ,NR,IB,I,L1,K1,IP,LD,L2,
     &  IDO,IDOT,IPM,I1,II
      DOUBLE PRECISION WA,TPI,ARGH,FI,ARGLD,ARG,WIFAC
      DIMENSION       WA(*)      ,WIFAC(*)    ,NTRYH(4)
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/3,4,2,5/
      NL = N
      NF = 0
      J = 0
  101 J = J+1
      IF (J-4) 102,102,103
  102 NTRY = NTRYH(J)
      GO TO 104
  103 NTRY = NTRY+2
  104 NQ = NL/NTRY
      NR = NL-NTRY*NQ
      IF (NR) 101,105,101
  105 NF = NF+1
      WIFAC(NF+2) = DBLE(NTRY)
      NL = NQ
      IF (NTRY .NE. 2) GO TO 107
      IF (NF .EQ. 1) GO TO 107
      DO 106 I=2,NF
         IB = NF-I+2
         WIFAC(IB+2) = WIFAC(IB+1)
  106 CONTINUE
      WIFAC(3) = 2.D0
  107 IF (NL .NE. 1) GO TO 104
      WIFAC(1) = DBLE(N)
      WIFAC(2) = DBLE(NF)
      TPI = 2.D0*(4.D0*ATAN(1.D0))
      ARGH = TPI/DBLE(N)
      I = 2
      L1 = 1
      DO 110 K1=1,NF
         IP = NINT(WIFAC(K1+2))
         LD = 0
         L2 = L1*IP
         IDO = N/L2
         IDOT = IDO+IDO+2
         IPM = IP-1
         DO 109 J=1,IPM
            I1 = I
            WA(I-1) = 1.D0
            WA(I) = 0.D0
            LD = LD+L1
            FI = 0.D0
            ARGLD = DBLE(LD)*ARGH
            DO 108 II=4,IDOT,2
               I = I+2
               FI = FI+1.D0
               ARG = FI*ARGLD
               WA(I-1) = COS(ARG)
               WA(I) = SIN(ARG)
  108       CONTINUE
            IF (IP .LE. 5) GO TO 109
            WA(I1-1) = WA(I-1)
            WA(I1) = WA(I)
  109    CONTINUE
         L1 = L2
  110 CONTINUE
      RETURN
      END

C****************************************************************************
      SUBROUTINE CFFTF1 (N,C,CH,WA,WIFAC)
      IMPLICIT NONE
      INTEGER N,NF,NA,L1,IW,K1,IP,L2,IDO,IDOT,IDL1,IX2,IX3,IX4,N2,
     &  I,NAC
      DOUBLE PRECISION C,CH,WA,WIFAC
      DIMENSION       CH(*)      ,C(*)           ,WA(*)   ,WIFAC(*)
      NF = NINT(WIFAC(2))
      NA = 0
      L1 = 1
      IW = 1
      DO 116 K1=1,NF
         IP = NINT(WIFAC(K1+2))
         L2 = IP*L1
         IDO = N/L2
         IDOT = IDO+IDO
         IDL1 = IDOT*L1
         IF (IP .NE. 4) GO TO 103
         IX2 = IW+IDOT
         IX3 = IX2+IDOT
         IF (NA .NE. 0) GO TO 101
         CALL PASSF4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
         GO TO 102
  101    CALL PASSF4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
  102    NA = 1-NA
         GO TO 115
  103    IF (IP .NE. 2) GO TO 106
         IF (NA .NE. 0) GO TO 104
         CALL PASSF2 (IDOT,L1,C,CH,WA(IW))
         GO TO 105
  104    CALL PASSF2 (IDOT,L1,CH,C,WA(IW))
  105    NA = 1-NA
         GO TO 115
  106    IF (IP .NE. 3) GO TO 109
         IX2 = IW+IDOT
         IF (NA .NE. 0) GO TO 107
         CALL PASSF3 (IDOT,L1,C,CH,WA(IW),WA(IX2))
         GO TO 108
  107    CALL PASSF3 (IDOT,L1,CH,C,WA(IW),WA(IX2))
  108    NA = 1-NA
         GO TO 115
  109    IF (IP .NE. 5) GO TO 112
         IX2 = IW+IDOT
         IX3 = IX2+IDOT
         IX4 = IX3+IDOT
         IF (NA .NE. 0) GO TO 110
         CALL PASSF5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 111
  110    CALL PASSF5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
  111    NA = 1-NA
         GO TO 115
  112    IF (NA .NE. 0) GO TO 113
         CALL PASSF (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
         GO TO 114
  113    CALL PASSF (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
  114    IF (NAC .NE. 0) NA = 1-NA
  115    L1 = L2
         IW = IW+(IP-1)*IDOT
  116 CONTINUE
      IF (NA .EQ. 0) RETURN
      N2 = N+N
      DO 117 I=1,N2
         C(I) = CH(I)
  117 CONTINUE
      RETURN
      END

C****************************************************************************
      SUBROUTINE CFFTB1 (N,C,CH,WA,WIFAC)
      IMPLICIT NONE
      INTEGER N,NF,NA,L1,IW,K1,IP,L2,IDO,IDOT,IDL1,IX2,IX3,IX4,N2,
     &  I,NAC
      DOUBLE PRECISION C,CH,WA,WIFAC
      DIMENSION       CH(*)      ,C(*)           ,WA(*)   ,WIFAC(*)
      NF = NINT(WIFAC(2))
      NA = 0
      L1 = 1
      IW = 1
      DO 116 K1=1,NF
         IP = NINT(WIFAC(K1+2))
         L2 = IP*L1
         IDO = N/L2
         IDOT = IDO+IDO
         IDL1 = IDOT*L1
         IF (IP .NE. 4) GO TO 103
         IX2 = IW+IDOT
         IX3 = IX2+IDOT
         IF (NA .NE. 0) GO TO 101
         CALL PASSB4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
         GO TO 102
  101    CALL PASSB4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
  102    NA = 1-NA
         GO TO 115
  103    IF (IP .NE. 2) GO TO 106
         IF (NA .NE. 0) GO TO 104
         CALL PASSB2 (IDOT,L1,C,CH,WA(IW))
         GO TO 105
  104    CALL PASSB2 (IDOT,L1,CH,C,WA(IW))
  105    NA = 1-NA
         GO TO 115
  106    IF (IP .NE. 3) GO TO 109
         IX2 = IW+IDOT
         IF (NA .NE. 0) GO TO 107
         CALL PASSB3 (IDOT,L1,C,CH,WA(IW),WA(IX2))
         GO TO 108
  107    CALL PASSB3 (IDOT,L1,CH,C,WA(IW),WA(IX2))
  108    NA = 1-NA
         GO TO 115
  109    IF (IP .NE. 5) GO TO 112
         IX2 = IW+IDOT
         IX3 = IX2+IDOT
         IX4 = IX3+IDOT
         IF (NA .NE. 0) GO TO 110
         CALL PASSB5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 111
  110    CALL PASSB5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
  111    NA = 1-NA
         GO TO 115
  112    IF (NA .NE. 0) GO TO 113
         CALL PASSB (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
         GO TO 114
  113    CALL PASSB (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
  114    IF (NAC .NE. 0) NA = 1-NA
  115    L1 = L2
         IW = IW+(IP-1)*IDOT
  116 CONTINUE
      IF (NA .EQ. 0) RETURN
      N2 = N+N
      DO 117 I=1,N2
         C(I) = CH(I)
  117 CONTINUE
      RETURN
      END

C****************************************************************************
      SUBROUTINE PASSB (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
      IMPLICIT NONE
      INTEGER NAC,IDO,IP,L1,IDL1,IDOT,IPP2,IPPH,IDP,J,K,I,IDL,LC,L,
     &  IK,IDLJ,JC,INC,IDIJ,IDJ
      DOUBLE PRECISION CC,C1,C2,CH,CH2,WA,WAR,WAI
      DIMENSION       CH(IDO,L1,IP)          ,CC(IDO,IP,L1)      ,
     1         C1(IDO,L1,IP)          ,WA(*)  ,C2(IDL1,IP),
     2         CH2(IDL1,IP)
      IDOT = IDO/2
      IPP2 = IP+2
      IPPH = (IP+1)/2
      IDP = IP*IDO
C
      IF (IDO .LT. L1) GO TO 106
      DO 103 J=2,IPPH
         JC = IPP2-J
         DO 102 K=1,L1
            DO 101 I=1,IDO
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
  101       CONTINUE
  102    CONTINUE
  103 CONTINUE
      DO 105 K=1,L1
         DO 104 I=1,IDO
            CH(I,K,1) = CC(I,1,K)
  104    CONTINUE
  105 CONTINUE
      GO TO 112
  106 DO 109 J=2,IPPH
         JC = IPP2-J
         DO 108 I=1,IDO
            DO 107 K=1,L1
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
  107       CONTINUE
  108    CONTINUE
  109 CONTINUE
      DO 111 I=1,IDO
         DO 110 K=1,L1
            CH(I,K,1) = CC(I,1,K)
  110    CONTINUE
  111 CONTINUE
  112 IDL = 2-IDO
      INC = 0
      DO 116 L=2,IPPH
         LC = IPP2-L
         IDL = IDL+IDO
         DO 113 IK=1,IDL1
            C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2)
            C2(IK,LC) = WA(IDL)*CH2(IK,IP)
  113    CONTINUE
         IDLJ = IDL
         INC = INC+IDO
         DO 115 J=3,IPPH
            JC = IPP2-J
            IDLJ = IDLJ+INC
            IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP
            WAR = WA(IDLJ-1)
            WAI = WA(IDLJ)
            DO 114 IK=1,IDL1
               C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J)
               C2(IK,LC) = C2(IK,LC)+WAI*CH2(IK,JC)
  114       CONTINUE
  115    CONTINUE
  116 CONTINUE
      DO 118 J=2,IPPH
         DO 117 IK=1,IDL1
            CH2(IK,1) = CH2(IK,1)+CH2(IK,J)
  117    CONTINUE
  118 CONTINUE
      DO 120 J=2,IPPH
         JC = IPP2-J
         DO 119 IK=2,IDL1,2
            CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC)
            CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC)
            CH2(IK,J) = C2(IK,J)+C2(IK-1,JC)
            CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC)
  119    CONTINUE
  120 CONTINUE
      NAC = 1
      IF (IDO .EQ. 2) RETURN
      NAC = 0
      DO 121 IK=1,IDL1
         C2(IK,1) = CH2(IK,1)
  121 CONTINUE
      DO 123 J=2,IP
         DO 122 K=1,L1
            C1(1,K,J) = CH(1,K,J)
            C1(2,K,J) = CH(2,K,J)
  122    CONTINUE
  123 CONTINUE
      IF (IDOT .GT. L1) GO TO 127
      IDIJ = 0
      DO 126 J=2,IP
         IDIJ = IDIJ+2
         DO 125 I=4,IDO,2
            IDIJ = IDIJ+2
            DO 124 K=1,L1
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
  124       CONTINUE
  125    CONTINUE
  126 CONTINUE
      RETURN
  127 IDJ = 2-IDO
      DO 130 J=2,IP
         IDJ = IDJ+IDO
         DO 129 K=1,L1
            IDIJ = IDJ
            DO 128 I=4,IDO,2
               IDIJ = IDIJ+2
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
  128       CONTINUE
  129    CONTINUE
  130 CONTINUE
      RETURN
      END

C****************************************************************************
      SUBROUTINE PASSB2 (IDO,L1,CC,CH,WA1)
      IMPLICIT NONE
      INTEGER IDO,L1,K,I
      DOUBLE PRECISION CC,CH,WA1,TR2,TI2
      DIMENSION       CC(IDO,2,L1)           ,CH(IDO,L1,2)        ,
     1         WA1(1)
      IF (IDO .GT. 2) GO TO 102
      DO 101 K=1,L1
         CH(1,K,1) = CC(1,1,K)+CC(1,2,K)
         CH(1,K,2) = CC(1,1,K)-CC(1,2,K)
         CH(2,K,1) = CC(2,1,K)+CC(2,2,K)
         CH(2,K,2) = CC(2,1,K)-CC(2,2,K)
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K)
            TR2 = CC(I-1,1,K)-CC(I-1,2,K)
            CH(I,K,1) = CC(I,1,K)+CC(I,2,K)
            TI2 = CC(I,1,K)-CC(I,2,K)
            CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2
            CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2
  103    CONTINUE
  104 CONTINUE
      RETURN
      END

C****************************************************************************
      SUBROUTINE PASSB3 (IDO,L1,CC,CH,WA1,WA2)
      IMPLICIT NONE
      INTEGER IDO,L1,K,I
      DOUBLE PRECISION CC,CH,WA1,WA2,TAUR,TAUI,TR2,CR2,TI2,CI2,CR3,CI3,
     &  DR2,DR3,DI2,DI3
      DIMENSION       CC(IDO,3,L1)           ,CH(IDO,L1,3)        ,
     1         WA1(*)     ,WA2(*)
      DATA TAUR,TAUI /-.5D0,.866025403784439D0/
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TR2 = CC(1,2,K)+CC(1,3,K)
         CR2 = CC(1,1,K)+TAUR*TR2
         CH(1,K,1) = CC(1,1,K)+TR2
         TI2 = CC(2,2,K)+CC(2,3,K)
         CI2 = CC(2,1,K)+TAUR*TI2
         CH(2,K,1) = CC(2,1,K)+TI2
         CR3 = TAUI*(CC(1,2,K)-CC(1,3,K))
         CI3 = TAUI*(CC(2,2,K)-CC(2,3,K))
         CH(1,K,2) = CR2-CI3
         CH(1,K,3) = CR2+CI3
         CH(2,K,2) = CI2+CR3
         CH(2,K,3) = CI2-CR3
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            TR2 = CC(I-1,2,K)+CC(I-1,3,K)
            CR2 = CC(I-1,1,K)+TAUR*TR2
            CH(I-1,K,1) = CC(I-1,1,K)+TR2
            TI2 = CC(I,2,K)+CC(I,3,K)
            CI2 = CC(I,1,K)+TAUR*TI2
            CH(I,K,1) = CC(I,1,K)+TI2
            CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))
            CI3 = TAUI*(CC(I,2,K)-CC(I,3,K))
            DR2 = CR2-CI3
            DR3 = CR2+CI3
            DI2 = CI2+CR3
            DI3 = CI2-CR3
            CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2
            CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2
            CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3
            CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3
  103    CONTINUE
  104 CONTINUE
      RETURN
      END

C****************************************************************************
      SUBROUTINE PASSB4 (IDO,L1,CC,CH,WA1,WA2,WA3)
      IMPLICIT NONE
      INTEGER IDO,L1,K,I
      DOUBLE PRECISION CC,CH,WA1,WA2,WA3,TI1,TI2,TI3,TI4,TR1,TR2,TR3,
     &  TR4,CR3,CR2,CI3,CR4,CI4,CI2
      DIMENSION       CC(IDO,4,L1)           ,CH(IDO,L1,4)        ,
     1         WA1(*)     ,WA2(*)     ,WA3(*)
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TI1 = CC(2,1,K)-CC(2,3,K)
         TI2 = CC(2,1,K)+CC(2,3,K)
         TR4 = CC(2,4,K)-CC(2,2,K)
         TI3 = CC(2,2,K)+CC(2,4,K)
         TR1 = CC(1,1,K)-CC(1,3,K)
         TR2 = CC(1,1,K)+CC(1,3,K)
         TI4 = CC(1,2,K)-CC(1,4,K)
         TR3 = CC(1,2,K)+CC(1,4,K)
         CH(1,K,1) = TR2+TR3
         CH(1,K,3) = TR2-TR3
         CH(2,K,1) = TI2+TI3
         CH(2,K,3) = TI2-TI3
         CH(1,K,2) = TR1+TR4
         CH(1,K,4) = TR1-TR4
         CH(2,K,2) = TI1+TI4
         CH(2,K,4) = TI1-TI4
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            TI1 = CC(I,1,K)-CC(I,3,K)
            TI2 = CC(I,1,K)+CC(I,3,K)
            TI3 = CC(I,2,K)+CC(I,4,K)
            TR4 = CC(I,4,K)-CC(I,2,K)
            TR1 = CC(I-1,1,K)-CC(I-1,3,K)
            TR2 = CC(I-1,1,K)+CC(I-1,3,K)
            TI4 = CC(I-1,2,K)-CC(I-1,4,K)
            TR3 = CC(I-1,2,K)+CC(I-1,4,K)
            CH(I-1,K,1) = TR2+TR3
            CR3 = TR2-TR3
            CH(I,K,1) = TI2+TI3
            CI3 = TI2-TI3
            CR2 = TR1+TR4
            CR4 = TR1-TR4
            CI2 = TI1+TI4
            CI4 = TI1-TI4
            CH(I-1,K,2) = WA1(I-1)*CR2-WA1(I)*CI2
            CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2
            CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3
            CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3
            CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4
            CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4
  103    CONTINUE
  104 CONTINUE
      RETURN
      END

C****************************************************************************
      SUBROUTINE PASSB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
      IMPLICIT NONE
      INTEGER IDO,L1,K,I
      DOUBLE PRECISION CC,CH,WA1,WA2,WA3,WA4,TR11,TI11,TR12,TI12,
     &  TI2,TI3,TI4,TI5,TR2,TR3,TR4,TR5,CR2,CI2,CR3,CI3,CR4,CI4,CR5,CI5,
     &  DR3,DI3,DR4,DI4,DR5,DI5,DR2,DI2
      DIMENSION       CC(IDO,5,L1)           ,CH(IDO,L1,5)        ,
     1         WA1(*)     ,WA2(*)     ,WA3(*)        ,WA4(*)
      DATA TR11,TI11,TR12,TI12 /.309016994374947D0,.951056516295154D0,
     1-.809016994374947D0,.587785252292473D0/
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TI5 = CC(2,2,K)-CC(2,5,K)
         TI2 = CC(2,2,K)+CC(2,5,K)
         TI4 = CC(2,3,K)-CC(2,4,K)
         TI3 = CC(2,3,K)+CC(2,4,K)
         TR5 = CC(1,2,K)-CC(1,5,K)
         TR2 = CC(1,2,K)+CC(1,5,K)
         TR4 = CC(1,3,K)-CC(1,4,K)
         TR3 = CC(1,3,K)+CC(1,4,K)
         CH(1,K,1) = CC(1,1,K)+TR2+TR3
         CH(2,K,1) = CC(2,1,K)+TI2+TI3
         CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3
         CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3
         CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3
         CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3
         CR5 = TI11*TR5+TI12*TR4
         CI5 = TI11*TI5+TI12*TI4
         CR4 = TI12*TR5-TI11*TR4
         CI4 = TI12*TI5-TI11*TI4
         CH(1,K,2) = CR2-CI5
         CH(1,K,5) = CR2+CI5
         CH(2,K,2) = CI2+CR5
         CH(2,K,3) = CI3+CR4
         CH(1,K,3) = CR3-CI4
         CH(1,K,4) = CR3+CI4
         CH(2,K,4) = CI3-CR4
         CH(2,K,5) = CI2-CR5
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            TI5 = CC(I,2,K)-CC(I,5,K)
            TI2 = CC(I,2,K)+CC(I,5,K)
            TI4 = CC(I,3,K)-CC(I,4,K)
            TI3 = CC(I,3,K)+CC(I,4,K)
            TR5 = CC(I-1,2,K)-CC(I-1,5,K)
            TR2 = CC(I-1,2,K)+CC(I-1,5,K)
            TR4 = CC(I-1,3,K)-CC(I-1,4,K)
            TR3 = CC(I-1,3,K)+CC(I-1,4,K)
            CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
            CH(I,K,1) = CC(I,1,K)+TI2+TI3
            CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
            CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
            CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
            CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
            CR5 = TI11*TR5+TI12*TR4
            CI5 = TI11*TI5+TI12*TI4
            CR4 = TI12*TR5-TI11*TR4
            CI4 = TI12*TI5-TI11*TI4
            DR3 = CR3-CI4
            DR4 = CR3+CI4
            DI3 = CI3+CR4
            DI4 = CI3-CR4
            DR5 = CR2+CI5
            DR2 = CR2-CI5
            DI5 = CI2-CR5
            DI2 = CI2+CR5
            CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2
            CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2
            CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3
            CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3
            CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4
            CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4
            CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5
            CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5
  103    CONTINUE
  104 CONTINUE
      RETURN
      END

C****************************************************************************
      SUBROUTINE PASSF (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
      IMPLICIT NONE
      INTEGER NAC,IDO,IP,L1,IDL1,IDOT,IPP2,IPPH,IDP,J,JC,K,I,IDL,
     &  INC,L,LC,IK,IDLJ,IDIJ,IDJ
      DOUBLE PRECISION CC,C1,C2,CH,CH2,WA,WAR,WAI
      DIMENSION       CH(IDO,L1,IP)          ,CC(IDO,IP,L1)      ,
     1         C1(IDO,L1,IP)          ,WA(*)  ,C2(IDL1,IP),
     2         CH2(IDL1,IP)
      IDOT = IDO/2
      IPP2 = IP+2
      IPPH = (IP+1)/2
      IDP = IP*IDO
C
      IF (IDO .LT. L1) GO TO 106
      DO 103 J=2,IPPH
         JC = IPP2-J
         DO 102 K=1,L1
            DO 101 I=1,IDO
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
  101       CONTINUE
  102    CONTINUE
  103 CONTINUE
      DO 105 K=1,L1
         DO 104 I=1,IDO
            CH(I,K,1) = CC(I,1,K)
  104    CONTINUE
  105 CONTINUE
      GO TO 112
  106 DO 109 J=2,IPPH
         JC = IPP2-J
         DO 108 I=1,IDO
            DO 107 K=1,L1
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
  107       CONTINUE
  108    CONTINUE
  109 CONTINUE
      DO 111 I=1,IDO
         DO 110 K=1,L1
            CH(I,K,1) = CC(I,1,K)
  110    CONTINUE
  111 CONTINUE
  112 IDL = 2-IDO
      INC = 0
      DO 116 L=2,IPPH
         LC = IPP2-L
         IDL = IDL+IDO
         DO 113 IK=1,IDL1
            C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2)
            C2(IK,LC) = -WA(IDL)*CH2(IK,IP)
  113    CONTINUE
         IDLJ = IDL
         INC = INC+IDO
         DO 115 J=3,IPPH
            JC = IPP2-J
            IDLJ = IDLJ+INC
            IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP
            WAR = WA(IDLJ-1)
            WAI = WA(IDLJ)
            DO 114 IK=1,IDL1
               C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J)
               C2(IK,LC) = C2(IK,LC)-WAI*CH2(IK,JC)
  114       CONTINUE
  115    CONTINUE
  116 CONTINUE
      DO 118 J=2,IPPH
         DO 117 IK=1,IDL1
            CH2(IK,1) = CH2(IK,1)+CH2(IK,J)
  117    CONTINUE
  118 CONTINUE
      DO 120 J=2,IPPH
         JC = IPP2-J
         DO 119 IK=2,IDL1,2
            CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC)
            CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC)
            CH2(IK,J) = C2(IK,J)+C2(IK-1,JC)
            CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC)
  119    CONTINUE
  120 CONTINUE
      NAC = 1
      IF (IDO .EQ. 2) RETURN
      NAC = 0
      DO 121 IK=1,IDL1
         C2(IK,1) = CH2(IK,1)
  121 CONTINUE
      DO 123 J=2,IP
         DO 122 K=1,L1
            C1(1,K,J) = CH(1,K,J)
            C1(2,K,J) = CH(2,K,J)
  122    CONTINUE
  123 CONTINUE
      IF (IDOT .GT. L1) GO TO 127
      IDIJ = 0
      DO 126 J=2,IP
         IDIJ = IDIJ+2
         DO 125 I=4,IDO,2
            IDIJ = IDIJ+2
            DO 124 K=1,L1
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)
  124       CONTINUE
  125    CONTINUE
  126 CONTINUE
      RETURN
  127 IDJ = 2-IDO
      DO 130 J=2,IP
         IDJ = IDJ+IDO
         DO 129 K=1,L1
            IDIJ = IDJ
            DO 128 I=4,IDO,2
               IDIJ = IDIJ+2
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)
  128       CONTINUE
  129    CONTINUE
  130 CONTINUE
      RETURN
      END

C****************************************************************************
      SUBROUTINE PASSF2 (IDO,L1,CC,CH,WA1)
      IMPLICIT NONE
      INTEGER IDO,L1,K,I
      DOUBLE PRECISION CC,CH,WA1,TR2,TI2
      DIMENSION       CC(IDO,2,L1)           ,CH(IDO,L1,2)        ,
     1         WA1(*)
      IF (IDO .GT. 2) GO TO 102
      DO 101 K=1,L1
         CH(1,K,1) = CC(1,1,K)+CC(1,2,K)
         CH(1,K,2) = CC(1,1,K)-CC(1,2,K)
         CH(2,K,1) = CC(2,1,K)+CC(2,2,K)
         CH(2,K,2) = CC(2,1,K)-CC(2,2,K)
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K)
            TR2 = CC(I-1,1,K)-CC(I-1,2,K)
            CH(I,K,1) = CC(I,1,K)+CC(I,2,K)
            TI2 = CC(I,1,K)-CC(I,2,K)
            CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2
            CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2
  103    CONTINUE
  104 CONTINUE
      RETURN
      END

C****************************************************************************
      SUBROUTINE PASSF3 (IDO,L1,CC,CH,WA1,WA2)
      IMPLICIT NONE
      INTEGER IDO,L1,K,I
      DOUBLE PRECISION CC,CH,WA1,WA2,TAUR,TAUI,TR2,CR2,TI2,CI2,CR3,CI3,
     &  DR2,DR3,DI2,DI3
      DIMENSION       CC(IDO,3,L1)           ,CH(IDO,L1,3)        ,
     1         WA1(*)     ,WA2(*)
      DATA TAUR,TAUI /-.5D0,-.866025403784439D0/
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TR2 = CC(1,2,K)+CC(1,3,K)
         CR2 = CC(1,1,K)+TAUR*TR2
         CH(1,K,1) = CC(1,1,K)+TR2
         TI2 = CC(2,2,K)+CC(2,3,K)
         CI2 = CC(2,1,K)+TAUR*TI2
         CH(2,K,1) = CC(2,1,K)+TI2
         CR3 = TAUI*(CC(1,2,K)-CC(1,3,K))
         CI3 = TAUI*(CC(2,2,K)-CC(2,3,K))
         CH(1,K,2) = CR2-CI3
         CH(1,K,3) = CR2+CI3
         CH(2,K,2) = CI2+CR3
         CH(2,K,3) = CI2-CR3
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            TR2 = CC(I-1,2,K)+CC(I-1,3,K)
            CR2 = CC(I-1,1,K)+TAUR*TR2
            CH(I-1,K,1) = CC(I-1,1,K)+TR2
            TI2 = CC(I,2,K)+CC(I,3,K)
            CI2 = CC(I,1,K)+TAUR*TI2
            CH(I,K,1) = CC(I,1,K)+TI2
            CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))
            CI3 = TAUI*(CC(I,2,K)-CC(I,3,K))
            DR2 = CR2-CI3
            DR3 = CR2+CI3
            DI2 = CI2+CR3
            DI3 = CI2-CR3
            CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2
            CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2
            CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3
            CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3
  103    CONTINUE
  104 CONTINUE
      RETURN
      END

C****************************************************************************
      SUBROUTINE PASSF4 (IDO,L1,CC,CH,WA1,WA2,WA3)
      IMPLICIT NONE
      INTEGER IDO,L1,K,I
      DOUBLE PRECISION CC,CH,WA1,WA2,WA3,TI1,TI2,TI3,TI4,TR1,TR2,TR3,
     &  TR4,CR2,CR3,CR4,CI2,CI3,CI4
      DIMENSION       CC(IDO,4,L1)           ,CH(IDO,L1,4)        ,
     1         WA1(*)     ,WA2(*)     ,WA3(*)
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TI1 = CC(2,1,K)-CC(2,3,K)
         TI2 = CC(2,1,K)+CC(2,3,K)
         TR4 = CC(2,2,K)-CC(2,4,K)
         TI3 = CC(2,2,K)+CC(2,4,K)
         TR1 = CC(1,1,K)-CC(1,3,K)
         TR2 = CC(1,1,K)+CC(1,3,K)
         TI4 = CC(1,4,K)-CC(1,2,K)
         TR3 = CC(1,2,K)+CC(1,4,K)
         CH(1,K,1) = TR2+TR3
         CH(1,K,3) = TR2-TR3
         CH(2,K,1) = TI2+TI3
         CH(2,K,3) = TI2-TI3
         CH(1,K,2) = TR1+TR4
         CH(1,K,4) = TR1-TR4
         CH(2,K,2) = TI1+TI4
         CH(2,K,4) = TI1-TI4
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            TI1 = CC(I,1,K)-CC(I,3,K)
            TI2 = CC(I,1,K)+CC(I,3,K)
            TI3 = CC(I,2,K)+CC(I,4,K)
            TR4 = CC(I,2,K)-CC(I,4,K)
            TR1 = CC(I-1,1,K)-CC(I-1,3,K)
            TR2 = CC(I-1,1,K)+CC(I-1,3,K)
            TI4 = CC(I-1,4,K)-CC(I-1,2,K)
            TR3 = CC(I-1,2,K)+CC(I-1,4,K)
            CH(I-1,K,1) = TR2+TR3
            CR3 = TR2-TR3
            CH(I,K,1) = TI2+TI3
            CI3 = TI2-TI3
            CR2 = TR1+TR4
            CR4 = TR1-TR4
            CI2 = TI1+TI4
            CI4 = TI1-TI4
            CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2
            CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2
            CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3
            CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3
            CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4
            CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4
  103    CONTINUE
  104 CONTINUE
      RETURN
      END

C****************************************************************************
      SUBROUTINE PASSF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
      IMPLICIT NONE
      INTEGER IDO,L1,K,I
      DOUBLE PRECISION CC,CH,WA1,WA2,WA3,WA4,TR11,TI11,TR12,TI12,
     &  TI2,TI3,TI4,TI5,TR2,TR3,TR4,TR5,CI2,CI3,CI4,CI5,CR2,CR3,CR4,
     &  CR5,DI2,DI3,DI4,DI5,DR2,DR3,DR4,DR5
      DIMENSION       CC(IDO,5,L1)           ,CH(IDO,L1,5)        ,
     1         WA1(*)     ,WA2(*)     ,WA3(*)        ,WA4(*)
      DATA TR11,TI11,TR12,TI12 /.309016994374947D0,-.951056516295154D0,
     1-.809016994374947D0,-.587785252292473D0/
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TI5 = CC(2,2,K)-CC(2,5,K)
         TI2 = CC(2,2,K)+CC(2,5,K)
         TI4 = CC(2,3,K)-CC(2,4,K)
         TI3 = CC(2,3,K)+CC(2,4,K)
         TR5 = CC(1,2,K)-CC(1,5,K)
         TR2 = CC(1,2,K)+CC(1,5,K)
         TR4 = CC(1,3,K)-CC(1,4,K)
         TR3 = CC(1,3,K)+CC(1,4,K)
         CH(1,K,1) = CC(1,1,K)+TR2+TR3
         CH(2,K,1) = CC(2,1,K)+TI2+TI3
         CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3
         CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3
         CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3
         CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3
         CR5 = TI11*TR5+TI12*TR4
         CI5 = TI11*TI5+TI12*TI4
         CR4 = TI12*TR5-TI11*TR4
         CI4 = TI12*TI5-TI11*TI4
         CH(1,K,2) = CR2-CI5
         CH(1,K,5) = CR2+CI5
         CH(2,K,2) = CI2+CR5
         CH(2,K,3) = CI3+CR4
         CH(1,K,3) = CR3-CI4
         CH(1,K,4) = CR3+CI4
         CH(2,K,4) = CI3-CR4
         CH(2,K,5) = CI2-CR5
  101 CONTINUE
      RETURN
  102 DO 104 K=1,L1
         DO 103 I=2,IDO,2
            TI5 = CC(I,2,K)-CC(I,5,K)
            TI2 = CC(I,2,K)+CC(I,5,K)
            TI4 = CC(I,3,K)-CC(I,4,K)
            TI3 = CC(I,3,K)+CC(I,4,K)
            TR5 = CC(I-1,2,K)-CC(I-1,5,K)
            TR2 = CC(I-1,2,K)+CC(I-1,5,K)
            TR4 = CC(I-1,3,K)-CC(I-1,4,K)
            TR3 = CC(I-1,3,K)+CC(I-1,4,K)
            CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
            CH(I,K,1) = CC(I,1,K)+TI2+TI3
            CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
            CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
            CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
            CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
            CR5 = TI11*TR5+TI12*TR4
            CI5 = TI11*TI5+TI12*TI4
            CR4 = TI12*TR5-TI11*TR4
            CI4 = TI12*TI5-TI11*TI4
            DR3 = CR3-CI4
            DR4 = CR3+CI4
            DI3 = CI3+CR4
            DI4 = CI3-CR4
            DR5 = CR2+CI5
            DR2 = CR2-CI5
            DI5 = CI2-CR5
            DI2 = CI2+CR5
            CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2
            CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2
            CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3
            CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3
            CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4
            CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4
            CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5
            CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5
  103    CONTINUE
  104 CONTINUE
      RETURN
      END


!------------------------------------------------------------------------
! fortfp ----------------------------------------------------------------
!    Fortran module that reads weights and biases -----------------------
!    and performs a forward propagation ---------------------------------
!------------------------------------------------------------------------

module fortfp

   implicit none

   ! activation function type
   type :: af
      procedure(ndarray), pointer, nopass :: f
   end type af

   ! array of function pointers for activation functions
   type (af), dimension(:), allocatable :: activfuncs

   ! layer type
   type :: layer

      real(8), dimension (:,:), pointer :: w, wd               		! matrix of weights
      real(8), dimension (:), pointer :: b, bd                 		! array of biases
      real(8), dimension (:), pointer :: y                     		! array of outputs
      procedure(ndarray), public, nopass, pointer :: af => null()	! activation function

   end type layer

   ! making pointers for working with input and output vectors
   real(8), dimension (:), pointer :: xp => null(), yp => null()

   ! neural network type: array of layers
   type :: nn

      type(layer), dimension (:), allocatable :: layers

   contains

      ! initialize neural network
      procedure, public :: init

      ! perform forward propagation
      procedure, public :: query

   end type nn

   ! dynamic arrays type
   type :: dyn_arr

      real(8), dimension(:), allocatable :: v
      real(8), dimension(:,:), allocatable :: m

   end type dyn_arr

   ! interface for activation functions
   abstract interface

      function ndarray(n)

         import af
         real(8), dimension (:), intent(in) :: n
         real(8), dimension (size(n)) :: ndarray

      end function ndarray

   end interface

   private :: readwb, init, query

contains

   !=====================================================================
   ! initialization of neural network
   subroutine init(this, layers, activ_func)

      class (nn), intent(inout) :: this

      ! array containing structure of layers, e.g., [100, 20, 30, 10]
      ! 100 input neurons; 20 neurons in first hidden layer;
      ! 30 neurons in second hidden layer; 10 neurons in output layer
      integer, dimension (:), intent(in) :: layers
      integer :: i, nin, nout, nl

      ! list of activation functions passed in
      type (af), dimension(0:), intent(in) :: activ_func
      real(8) :: sd
      type (dyn_arr) :: wb

      ! check if number of activation functions match number of layers
      if (size(activ_func) /= size(layers)) then
         print *, "The number of layers and activation functions do not match"
         stop
      endif

      ! number of layers and neurons
      nl = size(layers)
      nin = layers(1)
      nout = layers(nl)

      ! layers' numbers begin from 0
      allocate (this%layers(0:nl-1))

      ! loop over layers
      do i=1,nl-1

         ! allocate weights
         allocate (this%layers(i)%w(layers(i+1),layers(i)))
         allocate (this%layers(i)%wd(layers(i+1),layers(i)))

         ! allocate biases
         allocate (this%layers(i)%b(layers(i+1)))
         allocate (this%layers(i)%bd(layers(i+1)))

         ! set to 0
         this%layers(i)%wd = 0.d0
         this%layers(i)%bd = 0.d0

         ! allocate outputs
         allocate (this%layers(i)%y(layers(i+1)))

         ! read weights and biases
         call readwb(i, shape(this%layers(i)%w), wb)
         call readwb(i, shape(this%layers(i)%b), wb)
         this%layers(i)%w = wb%m
         this%layers(i)%b = wb%v

         deallocate (wb%v,wb%m)

         ! assign activation functions
         this%layers(i)%af => activ_func(i)%f

      enddo

      ! manually create layer 0
      allocate (this%layers(0)%y(nin))

      ! no weights in layer 0
      allocate (this%layers(0)%w(0,0), this%layers(0)%wd(0,0))
      allocate (this%layers(0)%b(0), this%layers(0)%bd(0))

      ! activation function for layer 0 (very likely null)
      this%layers(0)%af => activ_func(0)%f

   end subroutine init

   !=====================================================================
   ! given input x, performs forward propagation with results in this%y
   subroutine query(this, x)

      class(nn), intent(inout) :: this
      real(8), dimension(:), intent(in) :: x
      integer :: i, n, lm, ln
      integer :: j, k
      real(8) :: sum_j

      ! number of weight matrices
      ! layer 0 does not have it, so the number is 1 unit less
      n = size(this%layers) - 1

      ! copy x into y(0)
      this%layers(0)%y = x

      ! if activation function for inputs is used (very likely null)
      if (associated(this%layers(0)%af)) &
           this%layers(0)%y = this%layers(0)%af (this%layers(0)%y)

      ! loop over layers
      do i=1,n

         xp => this%layers(i-1)%y
         yp => this%layers(i)%y

         lm = ubound(this%layers(i)%w, 1)
         ln = ubound(this%layers(i)%w, 2)
         yp = this%layers(i)%b

         ! matrix-vector multiplication: lapack library
         !call dgemv("N", lm, ln, 1.d0, this%layers(i)%w, lm, xp, 1, 1.d0, yp, 1)

         ! uncomment this staff if there is no access to lapack
         do k=1,lm
            sum_j = 0.d0
            do j=1,ln
               sum_j = sum_j + this%layers(i)%w(k,j)*xp(j)
            enddo
            yp(k) =  sum_j + this%layers(i)%b(k)
         enddo

         ! apply activation
         yp = this%layers(i)%af(yp)

      enddo

   end subroutine query

   ! =====================================================================
   ! read weights and biases from file
   subroutine readwb(n_skip, frm, arr)

      integer, intent(in) :: n_skip
      type (dyn_arr), intent(inout) :: arr
      real(8), dimension(:), allocatable :: nd
      integer, dimension(:), intent(in) :: frm
      integer(4) :: samples, n, nm, osize
      integer(4) :: i, lm, ln, j, k, nsum

      ! nm = 2 for weights; nm = 1 for biases
      nm = size(frm)

      ! allocate arrays for weights and open file
      if (nm == 2) then
         samples = int(frm(1))*int(frm(2))
         osize = samples	! recording original size
         ! in case both dimensions are odd
         if (mod(samples, 2) == 1) samples = samples + 1
         allocate (arr%m(frm(1), frm(2)))
         open (1111, file = 'wb/w_0', status = 'old')
      ! allocate arrays for biases
      else
         samples=int(frm(1))
         osize = samples   	! recording original size
         ! in case dimension is odd
         if (mod(samples,2) == 1) samples = samples + 1
         allocate (arr%v(frm(1)))
         open (1111, file = 'wb/b_0', status = 'old')
      endif

      ! array for values
      allocate (nd(samples))
      nd = 0

      ! skip necessary lines
      if (n_skip > 1) then
         rewind (1111)
         do i=1,n_skip-1
            read (1111,*)
         end do
      end if
      ! read values from file
      read (1111,*) nd
      close (1111)

      ! weights
      if (nm == 2) then
         ln = size(arr%m, dim=2)
         lm = size(arr%m, dim=1)
         nsum = 1
         do j=1,lm
            do k=1,ln
               arr%m(j,k) = nd(nsum)
               nsum = nsum + 1
            enddo
         enddo
      ! biases
      else
         arr%v = nd(1:osize)
      endif

   end subroutine readwb
   !=====================================================================

   !---------------------------------------------------------------------
   ! ACTIVATION FUNCTIONS -----------------------------------------------
   !    all inputs and outputs are multidimensional ---------------------
   !    so even a scalar must be with dimension (1) ---------------------
   !---------------------------------------------------------------------

   !=====================================================================
   pure function sigmoid(x)

      ! sigmoid
      real(8), dimension (:), intent(in) :: x
      real(8), dimension (size(x)) :: sigmoid

      sigmoid = exp(-x)
      sigmoid = 1.d0 + sigmoid
      sigmoid = 1.d0 / sigmoid

   end function sigmoid

   ! =====================================================================
   pure function htan (x)

      ! hyperbolic tan
      real(8), dimension (:), intent(in) :: x
      real(8), dimension (size(x)) :: htan
      htan = tanh(x)

   end function htan

   ! =====================================================================
   pure function smax (y)

      ! softmax
      real(8), dimension(:), intent(in) :: y
      real(8), dimension (size(y)) :: smax
      real(8) :: sum_smax, l1, l2
      l1 = 1.d-9
      l2 = 0.999999999d0
      smax = exp(y)
      sum_smax = sum(smax)
      smax = smax / sum_smax
      where (smax > l2) smax = l2
      where (smax < l1) smax = l1

   end function smax

   ! =====================================================================
   pure function lrelu(x)

      ! leaky relu
      real(8), dimension (:), intent(in) :: x
      real(8), dimension (size(x)) :: lrelu
      lrelu = x
      where (x < 0.d0) lrelu = 0.01d0*x

   end function lrelu

   ! =====================================================================
   pure function relu(x)

      ! relu
      real(8), dimension (:), intent(in) :: x
      real(8), dimension (size(x)) :: relu

      relu = x
      where ( x < 0.d0 ) relu = 0.d0

   end function relu
   ! =====================================================================

   pure function no_activation(x)

      ! no activation
      real(8), dimension (:), intent(in) :: x
      real(8), dimension (size(x)) :: no_activation

      no_activation = x

   end function no_activation
   ! =====================================================================

end module fortfp


      real function intrpl(x1,y1,x2,y2,x)
c
c     + + + PURPOSE + + +
c
c     Function INTRPL interpolates between columnar table entries.
c
c     Called from: SR TABLE
c     Author(s): Ascough II, R. van der Zweep, V. Lopes
c     Reference in User Guide:
c
c     Version:
c     Date recoded:
c     Recoded by: Jim Ascough II
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      real x1, y1, x2, y2, x
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     x1 -
c     y1 -
c     x2 -
c     y2 -
c     x  -
c
c     + + + COMMON BLOCKS + + +
c
c     + + + LOCAL VARIABLES + + +
c
c     + + + LOCAL DEFINITIONS + + +
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c
cd    Modified by S. Dun, May 24, 2005
cd    intrpl = ((y2-y1)*(x-x1)/(x2-x1)) + y1
      if(x2 .eq. x1) then
          intrpl = (y2-y1)/2
      else
          intrpl = ((y2-y1)*(x-x1)/(x2-x1)) + y1
      endif
cd   End modifying
      return
      end


      double precision function DLNREL (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>>   1994-10-20 DLNREL Krogh  Changes to use M77CON
c>>   1990-11-27 DLNREL WV Snyder Initial Code.
c
c     Compute LOG(1+X).
c
c     This procedure uses approximation 2707 from Hart, et. al. when
c     1/sqrt(2) < 1+x < sqrt(2), and otherwise uses the Fortran
c     intrinsic logarithm routine.
c
c--D replaces "?": ?LNREL
      double precision X
      double precision P0, P1, P2, P3, P4, Q0, Q1, Q2, Q3, Z, ZSQ
      double precision BOT, TOP
      parameter (P0 = +0.75040 94990 77712 22174 55611 007 D+2 )
      parameter (P1 = -0.13456 69115 05043 02353 18253 537 D+3 )
      parameter (P2 = +0.74137 19213 24860 25127 79336 47  D+2 )
      parameter (P3 = -0.12772 49755 01233 08199 84385     D+2 )
      parameter (P4 = +0.33271 08381 08768 69381 44        D00 )
      parameter (Q0 = +0.37520 47495 38856 11087 27775 374 D+2 )
      parameter (Q1 = -0.79790 28073 71500 48794 39951 583 D+2 )
      parameter (Q2 = +0.56161 26132 11825 72920 58560 36  D+2 )
      parameter (Q3 = -0.14508 68091 85808 26853 62325     D+2 )
c     parameter (Q4 = +1.0                                 D00 )
      parameter (BOT = .70710 67811 86547 52440 D0 - 1.0D0 )
      parameter (TOP = 1.4142 13562 37309 50488 D0 - 1.0D0 )
c
      if (x .lt. bot .or. x .gt. top) then
         dlnrel = log(x+1.0d0)
      else
         z = x / (x+2.0d0)
         zsq = z*z
         dlnrel = z * ((((p4*zsq+p3)*zsq+p2)*zsq+p1)*zsq+p0)/
     1                ((((   zsq+q3)*zsq+q2)*zsq+q1)*zsq+q0)
      end if
      return
      end


c***********************************************************************
c	                    COORD_J2H.F
c***********************************************************************
*     PURPOSE: Converts from Jacobi to Helio coords.
*     ARGUMENTS:  Input is
*                    nbod ==> number of bodies (must be less than NBMAX)
*                             (integer)
*	             mass(*) ==>  masses (real array)
*		     xj(*),yj(*),zj(*) ==> Jacobi particle coords
*                                          (real array)
*		     vxj(*),vyj(*),vzj(*) ==> Jacobi particle velocities
*                                             (real array)
*                 Returned are
*                    xh(*),yh(*),zh(*) ==> Helio particle positions
*                                          (real array)
*                    vxh(*),vyh(*),vzh(*) ==> Helio particle velocities
*                                            (real array)
*
*     ALGORITHM: See my notes on Nov 21.
*
*     Authors:  Martin Duncan
*     WRITTEN:  Jan 27/93
*     REVISIONS: 2/17/95  HFL

	subroutine coord_j2h(nbod,mass,xj,yj,zj,vxj,vyj,vzj,
     &      xh,yh,zh,vxh,vyh,vzh)

      include '../swift.inc'

c...  Inputs:
	integer nbod
	real*8 mass(NPLMAX)
	real*8 xj(NPLMAX),yj(NPLMAX),zj(NPLMAX)
	real*8 vxj(NPLMAX),vyj(NPLMAX),vzj(NPLMAX)

c...  Outputs:
	real*8 xh(NPLMAX),yh(NPLMAX),zh(NPLMAX)
	real*8 vxh(NPLMAX),vyh(NPLMAX),vzh(NPLMAX)

c...  Internals:
	integer n
	real*8 sumx,sumy,sumz,sumvx,sumvy,sumvz
	real*8 eta(NPLMAX)

c----
c...  Executable code

c First calc. the array eta(*) then convert to jacobi coords

	eta(1) = mass(1)
	do n = 2,nbod
	   eta(n) = eta(n-1) + mass(n)
        enddo

        xh(1) = 0.d0
        yh(1) =  0.d0
	zh(1) =  0.d0
	vxh(1) =  0.d0
	vyh(1) =  0.d0
	vzh(1) =  0.d0

        xh(2) = xj(2)
        yh(2) = yj(2)
	zh(2) = zj(2)
	vxh(2) = vxj(2)
	vyh(2) = vyj(2)
	vzh(2) = vzj(2)

	sumx = mass(2)*xj(2)/eta(2)
	sumy = mass(2)*yj(2)/eta(2)
	sumz = mass(2)*zj(2)/eta(2)
	sumvx = mass(2)*vxj(2)/eta(2)
	sumvy = mass(2)*vyj(2)/eta(2)
	sumvz = mass(2)*vzj(2)/eta(2)

	do n=3,nbod
	  xh(n) = xj(n) + sumx
	  yh(n) = yj(n) + sumy
	  zh(n) = zj(n) + sumz
	  vxh(n) = vxj(n) + sumvx
	  vyh(n) = vyj(n) + sumvy
	  vzh(n) = vzj(n) + sumvz

	  if(n.lt.nbod) then
             sumx = sumx + mass(n)*xj(n)/eta(n)
             sumy = sumy + mass(n)*yj(n)/eta(n)
             sumz = sumz + mass(n)*zj(n)/eta(n)
             sumvx = sumvx + mass(n)*vxj(n)/eta(n)
             sumvy = sumvy + mass(n)*vyj(n)/eta(n)
             sumvz = sumvz + mass(n)*vzj(n)/eta(n)
          endif

	enddo

123	return
	end     ! coord_j2h

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


PROGRAM F050

    ! Copyright 2021 Melwyn Francis Carlo
    ! FILE REFERENCE: http://www.naturalnumbers.org/primes.html

    IMPLICIT NONE

    INTEGER :: PRIME_NUM
    CHARACTER (LEN=50), PARAMETER :: FILENAME = "problems/003/PrimeNumbers_Upto_1000000"

    INTEGER, DIMENSION(80000)     :: PRIMES_NUMS = 0;

    INTEGER :: N                = 1
    INTEGER :: COUNT_VAL        = 23
    INTEGER :: I_START          = 0
    INTEGER :: RESULTANT_PRIME  = 0

    LOGICAL :: PRIME_FOUND      = .FALSE.

    INTEGER :: I, I_BY_10, J, K, SUM_VAL

    OPEN (2, FILE = FILENAME, STATUS = 'OLD')

    DO
        READ(2, *, END=10) PRIME_NUM
        IF (PRIME_NUM > 1000000) EXIT
        IF (I_START == 0) THEN
            IF (PRIME_NUM > 100000) I_START = N - 1
        END IF
        PRIMES_NUMS(N) = PRIME_NUM
        N = N + 1
    END DO

    10 CLOSE(2)

    DO WHILE (COUNT_VAL < 1000)

        I = I_START
        PRIME_FOUND = .FALSE.

        DO WHILE (I < N)

            I_BY_10 = INT(I / 10)

            DO J = 1, I_BY_10

                SUM_VAL = 0

                DO K = J, (J + COUNT_VAL - 1)
                    SUM_VAL = SUM_VAL + PRIMES_NUMS(K)
                END DO

                IF (SUM_VAL > PRIMES_NUMS(I)) EXIT

                IF (SUM_VAL == PRIMES_NUMS(I)) THEN
                    RESULTANT_PRIME = PRIMES_NUMS(I)
                    PRIME_FOUND     = .TRUE.
                    COUNT_VAL       = COUNT_VAL + 1
                    EXIT
                END IF

            END DO

            IF (PRIME_FOUND) EXIT

            I = I + 1

        END DO

        COUNT_VAL = COUNT_VAL + 1

    END DO

    PRINT ('(I0)'), RESULTANT_PRIME

END PROGRAM F050


C     LAST UPDATE 18/02/94
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      REAL FUNCTION FUNC(X)
      IMPLICIT NONE
C
C Purpose: Evaluates the square of the residual for circle fitting
C          given X(1) = XC, X(2) = YC, X(3) = R
C
C Calls   0:
C Called by: FRPRMN, F1DIM
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C FIX include file:
C
      INCLUDE 'FIXPAR.COM'
C
C Arguments:
C
      REAL X(3)
C
C Common block:
C
      REAL XD(MAXPTS),YD(MAXPTS)
      INTEGER NDAT
      COMMON /CIRDAT/ XD,YD,NDAT
C
C Local variables:
C
      INTEGER I
C
C-----------------------------------------------------------------------
      FUNC = 0.0
      DO 10 I=1,NDAT
         FUNC = FUNC + (SQRT((X(1)-XD(I))**2+(X(2)-YD(I))**2) - X(3))**2
 10   CONTINUE
      RETURN
C
      END

C     LAST UPDATE 18/02/94
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE DFUNC(X,D)
      IMPLICIT NONE
C
C Purpose: Evaluates the gradient of the square of the residual for
C          circle fitting given X(1) = XC, X(2) = YC, X(3) = R,
C          returning partial derivatives in array D.
C
C
C Calls   0:
C Called by: FRPRMN, DF1DIM
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C FIX include file:
C
      INCLUDE 'FIXPAR.COM'
C
C Arguments:
C
      REAL X(3),D(3)
C
C Common block:
C
      REAL XD(MAXPTS),YD(MAXPTS)
      INTEGER NDAT
      COMMON /CIRDAT/ XD,YD,NDAT
C
C Local variables:
C
      INTEGER I
      REAL DD
C
C-----------------------------------------------------------------------
      DO 10 I=1,3
         D(I) = 0.0
 10   CONTINUE
      DO 20 I=1,NDAT
         DD = SQRT((X(1)-XD(I))**2+(X(2)-YD(I))**2)
         D(1) = D(1) + (X(1)-XD(I))*(1.0-X(3)/DD)
         D(2) = D(2) + (X(2)-YD(I))*(1.0-X(3)/DD)
         D(3) = D(3) + X(3) - DD
 20   CONTINUE
      DO 30 I=1,3
         D(I) = 2.0*D(I)
 30   CONTINUE
      RETURN
C
      END


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C BenchIT - Performance Measurement for Scientific Applications
C Contact: developer@benchit.org
C
C $Id: matmul_f_core.f 1 2009-09-11 12:26:19Z william $
C $URL: svn+ssh://william@rupert.zih.tu-dresden.de/svn-base/benchit-root/BenchITv6/kernel/numerical/matmul/F77/0/0/double/matmul_f_core.f $
C For license details see COPYING in the package base directory
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Kernel: Matrix Multiply (F77)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	SUBROUTINE multaijk( a, b, c, n)
	INTEGER*4 n,i,j,k
	double precision a(n,n), b(n,n), c(n,n)
	do 100 i=1,n
	do 100 j=1,n
	do 100 k=1,n
	   c(i,j)=c(i,j)+a(i,k)*b(k,j)
 100	CONTINUE
	RETURN
	END
c
	SUBROUTINE multaikj( a, b, c, n)
	INTEGER*4 n,i,j,k
	double precision a(n,n), b(n,n), c(n,n)
	do 100 i=1,n
	do 100 k=1,n
	do 100 j=1,n
	   c(i,j)=c(i,j)+a(i,k)*b(k,j)
 100	CONTINUE
	RETURN
	END
c
	SUBROUTINE multajik( a, b, c, n)
	INTEGER*4 n,i,j,k
	double precision a(n,n), b(n,n), c(n,n)
	do 100 j=1,n
	do 100 i=1,n
	do 100 k=1,n
	   c(i,j)=c(i,j)+a(i,k)*b(k,j)
 100	CONTINUE
	RETURN
	END
c
	SUBROUTINE multajki( a, b, c, n)
	INTEGER*4 n,i,j,k
	double precision a(n,n), b(n,n), c(n,n)
	do 100 j=1,n
	do 100 k=1,n
	do 100 i=1,n
	   c(i,j)=c(i,j)+a(i,k)*b(k,j)
 100	CONTINUE
	RETURN
	END
c
	SUBROUTINE multakij( a, b, c, n)
	INTEGER*4 n,i,j,k
	double precision a(n,n), b(n,n), c(n,n)
	do 100 k=1,n
	do 100 i=1,n
	do 100 j=1,n
	   c(i,j)=c(i,j)+a(i,k)*b(k,j)
 100	CONTINUE
	RETURN
	END
c
	SUBROUTINE multakji( a, b, c, n)
	INTEGER*4 n,i,j,k
	double precision a(n,n), b(n,n), c(n,n)
	do 100 k=1,n
	do 100 j=1,n
	do 100 i=1,n
	   c(i,j)=c(i,j)+a(i,k)*b(k,j)
 100	CONTINUE
	RETURN
	END


c---------------------------------------------------------------------
c---------------------------------------------------------------------
      subroutine l2norm (v, sum, nx, nxmax, ny, nz)
c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c   to compute the l2-norm of vector v.
c---------------------------------------------------------------------

      implicit none

c---------------------------------------------------------------------
c  input parameters
c---------------------------------------------------------------------
      integer nx, nxmax, ny, nz
      double precision  v(5,nxmax,ny,nz), sum(5)

c---------------------------------------------------------------------
c  local variables
c---------------------------------------------------------------------
      integer i, j, k, m

      do m = 1, 5
         sum(m) = 0.0d+00
      end do

      do k = 2, nz-1
         do j = 2, ny-1
            do i = 2, nx-1
               do m = 1, 5
                  sum(m) = sum(m) + v(m,i,j,k) * v(m,i,j,k)
               end do
            end do
         end do
      end do

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

      return
      end


      SUBROUTINE TRANEM (MCSID, NGRID, R, ICOMP, U, RC)
C*****
C     COMPUTES A STRESS TRANSFORMATION MATRIX U FOR TRIANGLES AND QUADS.
C     INPUTS
C        MCSID  ID OF COORDINATE SYSTEM REFERENCED ON MAT1,2 DATA CARD.
C        NGRID  3 FOR TRIANGLES, 4 FOR QUADS.
C        R      ARRAY OF BASIC LOCATIONS OF ELEMENT GRID PTS (3,NGRID).
C     OUTPUTS
C        ICOMP  1 (IF MAT X-AXIS IS USED) OR 2 (IF Y-AXIS IS USED).
C        U      ARRAY (3X3) FOR TRANSFORMATION, STORED BY ROW.
C        RC     BASIC LOCATION COORDINATES OF ELEMENT CENTER.
C     REQUIREMENTS
C        SUBROUTINE PRETRS MUST SET UP FOR TRANSS. SEE P.M. PAGE 3.4-66
C*****
      INTEGER ECPT(4),SUBNAM(2)
C
      REAL RC(3)
      REAL R(9)
      REAL U(9)
      REAL RCENT(4)
C
      EQUIVALENCE  (RCENT(1), ECPT(1))
C
      DATA SUBNAM /4HTRAN,2HEM/
C
C-----------------------------------------------------------------------
C
      IF(NGRID .NE.3 .AND. NGRID.NE.4 )  CALL MESAGE(-61,0,SUBNAM)
C*****
C     FIND THE UNIT NORMAL OF THE ELEMENT
C*****
      I = 3*(NGRID-3)
      VN1 = (R(8)-R(2))*(R(I+9)-R(6))-(R(9)-R(3))*(R(I+8)-R(5))
      VN2 = (R(9)-R(3))*(R(I+7)-R(4))-(R(7)-R(1))*(R(I+9)-R(6))
      VN3 = (R(7)-R(1))*(R(I+8)-R(5))-(R(8)-R(2))*(R(I+7)-R(4))
      TEMP = SQRT(VN1**2+VN2**2+VN3**2)
      IF(TEMP .LE. 0.0) CALL MESAGE(-61,0,SUBNAM)
      VN1 = VN1 / TEMP
      VN2 = VN2 / TEMP
      VN3 = VN3 / TEMP
C*****
C     GET THE UNIT VECTORS OF MCSID AT ELEM CENTER. PUT IN U TEMPORARILY
C*****
      GRDS = NGRID
      DO 20 IC=1,3
      SUM = 0.0
      DO 10 IG=1,NGRID
      K = 3*IG + IC-3
      SUM = SUM +R(K)
   10 CONTINUE
      RCENT(IC+1) = SUM / GRDS
      RC(IC) = RCENT(IC+1)
   20 CONTINUE
      ECPT(1) = MCSID
      CALL TRANSS(ECPT,U)
C*****
C     SELECT FIRST OR SECOND VECTOR TO PROJECT FOR ELEM-MAT X-AXIS
C*****
      VNDOTM=VN1*U(1)+VN2*U(4)+VN3*U(7)
      IF( VNDOTM**2 .GT. 0.4) GO TO 30
      ICOMP = 1
      VM1 = U(1)
      VM2 = U(4)
      VM3 = U(7)
      GO TO 40
   30 CONTINUE
      ICOMP = 2
      VM1 = U(2)
      VM2 = U(5)
      VM3 = U(8)
      VNDOTM = VN1*VM1+VN2*VM2+VN3*VM3
   40 CONTINUE
C*****
C     FIND COSINE AND SINE OF ANGLE
C*****
      VE1 = R(4) - R(1)
      VE2 = R(5) - R(2)
      VE3 = R(6) - R(3)
      C = VE1*(VM1-VNDOTM*VN1)
     *  + VE2*(VM2-VNDOTM*VN2)
     *  + VE3*(VM3-VNDOTM*VN3)
      S = VE1*(VM2*VN3-VM3*VN2)
     *  + VE2*(VM3*VN1-VM1*VN3)
     *  + VE3*(VM1*VN2-VM2*VN1)
      TEMP = SQRT(C*C+S*S)
      IF(TEMP .LE. 0.0) CALL MESAGE(-61,0,SUBNAM)
      C = C/TEMP
      S = S/TEMP
C*****
C     FILL IN THE U MATRIX, ROW STORED.
C*****
      U(1) = C*C
      U(4) = S*S
      U(7) = -C*S
      U(2) = U(4)
      U(5) = U(1)
      U(8) = -U(7)
      U(3) = 2.0*U(8)
      U(6) = -U(3)
      U(9) = U(1)-U(4)
C
      RETURN
C
      END


*DECK RPQR79
      SUBROUTINE RPQR79 (NDEG, COEFF, ROOT, IERR, WORK)
C***BEGIN PROLOGUE  RPQR79
C***PURPOSE  Find the zeros of a polynomial with real coefficients.
C***LIBRARY   SLATEC
C***CATEGORY  F1A1A
C***TYPE      SINGLE PRECISION (RPQR79-S, CPQR79-C)
C***KEYWORDS  COMPLEX POLYNOMIAL, POLYNOMIAL ROOTS, POLYNOMIAL ZEROS
C***AUTHOR  Vandevender, W. H., (SNLA)
C***DESCRIPTION
C
C   Abstract
C       This routine computes all zeros of a polynomial of degree NDEG
C       with real coefficients by computing the eigenvalues of the
C       companion matrix.
C
C   Description of Parameters
C       The user must dimension all arrays appearing in the call list
C            COEFF(NDEG+1), ROOT(NDEG), WORK(NDEG*(NDEG+2))
C
C    --Input--
C      NDEG    degree of polynomial
C
C      COEFF   REAL coefficients in descending order.  i.e.,
C              P(Z)= COEFF(1)*(Z**NDEG) + COEFF(NDEG)*Z + COEFF(NDEG+1)
C
C      WORK    REAL work array of dimension at least NDEG*(NDEG+2)
C
C   --Output--
C      ROOT    COMPLEX vector of roots
C
C      IERR    Output Error Code
C           - Normal Code
C          0  means the roots were computed.
C           - Abnormal Codes
C          1  more than 30 QR iterations on some eigenvalue of the
C             companion matrix
C          2  COEFF(1)=0.0
C          3  NDEG is invalid (less than or equal to 0)
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  HQR, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800601  DATE WRITTEN
C   890505  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   911010  Code reworked and simplified.  (RWC and WRB)
C***END PROLOGUE  RPQR79
      REAL COEFF(*), WORK(*), SCALE
      COMPLEX ROOT(*)
      INTEGER NDEG, IERR, K, KH, KWR, KWI, KCOL
C***FIRST EXECUTABLE STATEMENT  RPQR79
      IERR = 0
      IF (ABS(COEFF(1)) .EQ. 0.0) THEN
         IERR = 2
         CALL XERMSG ('SLATEC', 'RPQR79',
     +      'LEADING COEFFICIENT IS ZERO.', 2, 1)
         RETURN
      ENDIF
C
      IF (NDEG .LE. 0) THEN
         IERR = 3
         CALL XERMSG ('SLATEC', 'RPQR79', 'DEGREE INVALID.', 3, 1)
         RETURN
      ENDIF
C
      IF (NDEG .EQ. 1) THEN
         ROOT(1) = CMPLX(-COEFF(2)/COEFF(1),0.0)
         RETURN
      ENDIF
C
      SCALE = 1.0E0/COEFF(1)
      KH = 1
      KWR = KH+NDEG*NDEG
      KWI = KWR+NDEG
      KWEND = KWI+NDEG-1
C
      DO 10 K=1,KWEND
         WORK(K) = 0.0E0
   10 CONTINUE
C
      DO 20 K=1,NDEG
         KCOL = (K-1)*NDEG+1
         WORK(KCOL) = -COEFF(K+1)*SCALE
         IF (K .NE. NDEG) WORK(KCOL+K) = 1.0E0
   20 CONTINUE
C
      CALL HQR (NDEG,NDEG,1,NDEG,WORK(KH),WORK(KWR),WORK(KWI),IERR)
C
      IF (IERR .NE. 0) THEN
         IERR = 1
         CALL XERMSG ('SLATEC', 'CPQR79',
     +      'NO CONVERGENCE IN 30 QR ITERATIONS.', 1, 1)
         RETURN
      ENDIF
C
      DO 30 K=1,NDEG
         KM1 = K-1
         ROOT(K) = CMPLX(WORK(KWR+KM1),WORK(KWI+KM1))
   30 CONTINUE
      RETURN
      END