      SUBROUTINE FFT99(A,WORK,TRIGS,IFAX,INC,JUMP,N,LOT,ISIGN)
C
C PURPOSE      PERFORMS MULTIPLE FAST FOURIER TRANSFORMS.  THIS PACKAGE
C              WILL PERFORM A NUMBER OF SIMULTANEOUS REAL/HALF-COMPLEX
C              PERIODIC FOURIER TRANSFORMS OR CORRESPONDING INVERSE
C              TRANSFORMS, I.E.  GIVEN A SET OF REAL DATA VECTORS, THE
C              PACKAGE RETURNS A SET OF 'HALF-COMPLEX' FOURIER
C              COEFFICIENT VECTORS, OR VICE VERSA.  THE LENGTH OF THE
C              TRANSFORMS MUST BE AN EVEN NUMBER GREATER THAN 4 THAT HAS
C              NO OTHER FACTORS EXCEPT POSSIBLY POWERS OF 2, 3, AND 5.
C              THIS IS AN ALL FORTRAN VERSION OF THE CRAYLIB PACKAGE
C              THAT IS MOSTLY WRITTEN IN CAL.
C
C              THE PACKAGE FFT99F CONTAINS SEVERAL USER-LEVEL ROUTINES:
C
C            SUBROUTINE SET99
C                AN INITIALIZATION ROUTINE THAT MUST BE CALLED ONCE
C                BEFORE A SEQUENCE OF CALLS TO THE FFT ROUTINES
C                (PROVIDED THAT N IS NOT CHANGED).
C
C            SUBROUTINES FFT99 AND FFT991
C                TWO FFT ROUTINES THAT RETURN SLIGHTLY DIFFERENT
C                ARRANGEMENTS OF THE DATA IN GRIDPOINT SPACE.
C
C
C ACCESS       THIS FORTRAN VERSION MAY BE ACCESSED WITH
C
C                   *FORTRAN,P=XLIB,SN=FFT99F
C
C              TO ACCESS THE CRAY OBJECT CODE, CALLING THE USER ENTRY
C              POINTS FROM A CRAY PROGRAM IS SUFFICIENT.  THE SOURCE
C              FORTRAN AND CAL CODE FOR THE CRAYLIB VERSION MAY BE
C              ACCESSED USING
C
C                   FETCH P=CRAYLIB,SN=FFT99
C                   FETCH P=CRAYLIB,SN=CAL99
C
C USAGE        LET N BE OF THE FORM 2**P * 3**Q * 5**R, WHERE P .GE. 1,
C              Q .GE. 0, AND R .GE. 0.  THEN A TYPICAL SEQUENCE OF
C              CALLS TO TRANSFORM A GIVEN SET OF REAL VECTORS OF LENGTH
C              N TO A SET OF 'HALF-COMPLEX' FOURIER COEFFICIENT VECTORS
C              OF LENGTH N IS
C
C                   DIMENSION IFAX(13),TRIGS(3*N/2+1),A(M*(N+2)),
C                  +          WORK(M*(N+1))
C
C                   CALL SET99 (TRIGS, IFAX, N)
C                   CALL FFT99 (A,WORK,TRIGS,IFAX,INC,JUMP,N,M,ISIGN)
C
C              SEE THE INDIVIDUAL WRITE-UPS FOR SET99, FFT99, AND
C              FFT991 BELOW, FOR A DETAILED DESCRIPTION OF THE
C              ARGUMENTS.
C
C HISTORY      THE PACKAGE WAS WRITTEN BY CLIVE TEMPERTON AT ECMWF IN
C              NOVEMBER, 1978.  IT WAS MODIFIED, DOCUMENTED, AND TESTED
C              FOR NCAR BY RUSS REW IN SEPTEMBER, 1980.
C
C-----------------------------------------------------------------------
C
C SUBROUTINE SET99 (TRIGS, IFAX, N)
C
C PURPOSE      A SET-UP ROUTINE FOR FFT99 AND FFT991.  IT NEED ONLY BE
C              CALLED ONCE BEFORE A SEQUENCE OF CALLS TO THE FFT
C              ROUTINES (PROVIDED THAT N IS NOT CHANGED).
C
C ARGUMENT     IFAX(13),TRIGS(3*N/2+1)
C DIMENSIONS
C
C ARGUMENTS
C
C ON INPUT     TRIGS
C               A FLOATING POINT ARRAY OF DIMENSION 3*N/2 IF N/2 IS
C               EVEN, OR 3*N/2+1 IF N/2 IS ODD.
C
C              IFAX
C               AN INTEGER ARRAY.  THE NUMBER OF ELEMENTS ACTUALLY USED
C               WILL DEPEND ON THE FACTORIZATION OF N.  DIMENSIONING
C               IFAX FOR 13 SUFFICES FOR ALL N LESS THAN A MILLION.
C
C              N
C               AN EVEN NUMBER GREATER THAN 4 THAT HAS NO PRIME FACTOR
C               GREATER THAN 5.  N IS THE LENGTH OF THE TRANSFORMS (SEE
C               THE DOCUMENTATION FOR FFT99 AND FFT991 FOR THE
C               DEFINITIONS OF THE TRANSFORMS).
C
C ON OUTPUT    IFAX
C               CONTAINS THE FACTORIZATION OF N/2.  IFAX(1) IS THE
C               NUMBER OF FACTORS, AND THE FACTORS THEMSELVES ARE STORED
C               IN IFAX(2),IFAX(3),...  IF SET99 IS CALLED WITH N ODD,
C               OR IF N HAS ANY PRIME FACTORS GREATER THAN 5, IFAX(1)
C               IS SET TO -99.
C
C              TRIGS
C               AN ARRAY OF TRIGONOMETRIC FUNCTION VALUES SUBSEQUENTLY
C               USED BY THE FFT ROUTINES.
C
C-----------------------------------------------------------------------
C
C SUBROUTINE FFT991 (A,WORK,TRIGS,IFAX,INC,JUMP,N,M,ISIGN)
C                       AND
C SUBROUTINE FFT99 (A,WORK,TRIGS,IFAX,INC,JUMP,N,M,ISIGN)
C
C PURPOSE      PERFORM A NUMBER OF SIMULTANEOUS REAL/HALF-COMPLEX
C              PERIODIC FOURIER TRANSFORMS OR CORRESPONDING INVERSE
C              TRANSFORMS, USING ORDINARY SPATIAL ORDER OF GRIDPOINT
C              VALUES (FFT991) OR EXPLICIT CYCLIC CONTINUITY IN THE
C              GRIDPOINT VALUES (FFT99).  GIVEN A SET
C              OF REAL DATA VECTORS, THE PACKAGE RETURNS A SET OF
C              'HALF-COMPLEX' FOURIER COEFFICIENT VECTORS, OR VICE
C              VERSA.  THE LENGTH OF THE TRANSFORMS MUST BE AN EVEN
C              NUMBER THAT HAS NO OTHER FACTORS EXCEPT POSSIBLY POWERS
C              OF 2, 3, AND 5.  THESE VERSION OF FFT991 AND FFT99 ARE
C              OPTIMIZED FOR USE ON THE CRAY-1.
C
C ARGUMENT     A(M*(N+2)), WORK(M*(N+1)), TRIGS(3*N/2+1), IFAX(13)
C DIMENSIONS
C
C ARGUMENTS
C
C ON INPUT     A
C               AN ARRAY OF LENGTH M*(N+2) CONTAINING THE INPUT DATA
C               OR COEFFICIENT VECTORS.  THIS ARRAY IS OVERWRITTEN BY
C               THE RESULTS.
C
C              WORK
C               A WORK ARRAY OF DIMENSION M*(N+1)
C
C              TRIGS
C               AN ARRAY SET UP BY SET99, WHICH MUST BE CALLED FIRST.
C
C              IFAX
C               AN ARRAY SET UP BY SET99, WHICH MUST BE CALLED FIRST.
C
C              INC
C               THE INCREMENT (IN WORDS) BETWEEN SUCCESSIVE ELEMENTS OF
C               EACH DATA OR COEFFICIENT VECTOR (E.G.  INC=1 FOR
C               CONSECUTIVELY STORED DATA).
C
C              JUMP
C               THE INCREMENT (IN WORDS) BETWEEN THE FIRST ELEMENTS OF
C               SUCCESSIVE DATA OR COEFFICIENT VECTORS.  ON THE CRAY-1,
C               TRY TO ARRANGE DATA SO THAT JUMP IS NOT A MULTIPLE OF 8
C               (TO AVOID MEMORY BANK CONFLICTS).  FOR CLARIFICATION OF
C               INC AND JUMP, SEE THE EXAMPLES BELOW.
C
C              N
C               THE LENGTH OF EACH TRANSFORM (SEE DEFINITION OF
C               TRANSFORMS, BELOW).
C
C              M
C               THE NUMBER OF TRANSFORMS TO BE DONE SIMULTANEOUSLY.
C
C              ISIGN
C               = +1 FOR A TRANSFORM FROM FOURIER COEFFICIENTS TO
C                    GRIDPOINT VALUES.
C               = -1 FOR A TRANSFORM FROM GRIDPOINT VALUES TO FOURIER
C                    COEFFICIENTS.
C
C ON OUTPUT    A
C               IF ISIGN = +1, AND M COEFFICIENT VECTORS ARE SUPPLIED
C               EACH CONTAINING THE SEQUENCE:
C
C               A(0),B(0),A(1),B(1),...,A(N/2),B(N/2)  (N+2 VALUES)
C
C               THEN THE RESULT CONSISTS OF M DATA VECTORS EACH
C               CONTAINING THE CORRESPONDING N+2 GRIDPOINT VALUES:
C
C               FOR FFT991, X(0), X(1), X(2),...,X(N-1),0,0.
C               FOR FFT99, X(N-1),X(0),X(1),X(2),...,X(N-1),X(0).
C                   (EXPLICIT CYCLIC CONTINUITY)
C
C               WHEN ISIGN = +1, THE TRANSFORM IS DEFINED BY:
C                 X(J)=SUM(K=0,...,N-1)(C(K)*EXP(2*I*J*K*PI/N))
C                 WHERE C(K)=A(K)+I*B(K) AND C(N-K)=A(K)-I*B(K)
C                 AND I=SQRT (-1)
C
C               IF ISIGN = -1, AND M DATA VECTORS ARE SUPPLIED EACH
C               CONTAINING A SEQUENCE OF GRIDPOINT VALUES X(J) AS
C               DEFINED ABOVE, THEN THE RESULT CONSISTS OF M VECTORS
C               EACH CONTAINING THE CORRESPONDING FOURIER COFFICIENTS
C               A(K), B(K), 0 .LE. K .LE N/2.
C
C               WHEN ISIGN = -1, THE INVERSE TRANSFORM IS DEFINED BY:
C                 C(K)=(1/N)*SUM(J=0,...,N-1)(X(J)*EXP(-2*I*J*K*PI/N))
C                 WHERE C(K)=A(K)+I*B(K) AND I=SQRT(-1)
C
C               A CALL WITH ISIGN=+1 FOLLOWED BY A CALL WITH ISIGN=-1
C               (OR VICE VERSA) RETURNS THE ORIGINAL DATA.
C
C               NOTE: THE FACT THAT THE GRIDPOINT VALUES X(J) ARE REAL
C               IMPLIES THAT B(0)=B(N/2)=0.  FOR A CALL WITH ISIGN=+1,
C               IT IS NOT ACTUALLY NECESSARY TO SUPPLY THESE ZEROS.
C
C EXAMPLES      GIVEN 19 DATA VECTORS EACH OF LENGTH 64 (+2 FOR EXPLICIT
C               CYCLIC CONTINUITY), COMPUTE THE CORRESPONDING VECTORS OF
C               FOURIER COEFFICIENTS.  THE DATA MAY, FOR EXAMPLE, BE
C               ARRANGED LIKE THIS:
C
C FIRST DATA   A(1)=    . . .                A(66)=             A(70)
C VECTOR       X(63) X(0) X(1) X(2) ... X(63) X(0)  (4 EMPTY LOCATIONS)
C
C SECOND DATA  A(71)=   . . .                                  A(140)
C VECTOR       X(63) X(0) X(1) X(2) ... X(63) X(0)  (4 EMPTY LOCATIONS)
C
C               AND SO ON.  HERE INC=1, JUMP=70, N=64, M=19, ISIGN=-1,
C               AND FFT99 SHOULD BE USED (BECAUSE OF THE EXPLICIT CYCLIC
C               CONTINUITY).
C
C               ALTERNATIVELY THE DATA MAY BE ARRANGED LIKE THIS:
C
C                FIRST         SECOND                          LAST
C                DATA          DATA                            DATA
C                VECTOR        VECTOR                          VECTOR
C
C                 A(1)=         A(2)=                           A(19)=
C
C                 X(63)         X(63)       . . .               X(63)
C        A(20)=   X(0)          X(0)        . . .               X(0)
C        A(39)=   X(1)          X(1)        . . .               X(1)
C                  .             .                               .
C                  .             .                               .
C                  .             .                               .
C
C               IN WHICH CASE WE HAVE INC=19, JUMP=1, AND THE REMAINING
C               PARAMETERS ARE THE SAME AS BEFORE.  IN EITHER CASE, EACH
C               COEFFICIENT VECTOR OVERWRITES THE CORRESPONDING INPUT
C               DATA VECTOR.
C
C-----------------------------------------------------------------------
      DIMENSION A(JUMP*LOT),WORK((N+1)*LOT),TRIGS(3*N/2+1),IFAX(13)
C
C     SUBROUTINE "FFT99" - MULTIPLE FAST REAL PERIODIC TRANSFORM
C     CORRESPONDING TO OLD SCALAR ROUTINE FFT9
C     PROCEDURE USED TO CONVERT TO HALF-LENGTH COMPLEX TRANSFORM
C     IS GIVEN BY COOLEY, LEWIS AND WELCH (J. SOUND VIB., VOL. 12
C     (1970), 315-337)
C
C     A IS THE ARRAY CONTAINING INPUT AND OUTPUT DATA
C     WORK IS AN AREA OF SIZE (N+1)*LOT
C     TRIGS IS A PREVIOUSLY PREPARED LIST OF TRIG FUNCTION VALUES
C     IFAX IS A PREVIOUSLY PREPARED LIST OF FACTORS OF N/2
C     INC IS THE INCREMENT WITHIN EACH DATA 'VECTOR'
C         (E.G. INC=1 FOR CONSECUTIVELY STORED DATA)
C     JUMP IS THE INCREMENT BETWEEN THE START OF EACH DATA VECTOR
C     N IS THE LENGTH OF THE DATA VECTORS
C     LOT IS THE NUMBER OF DATA VECTORS
C     ISIGN = +1 FOR TRANSFORM FROM SPECTRAL TO GRIDPOINT
C           = -1 FOR TRANSFORM FROM GRIDPOINT TO SPECTRAL
C
C     ORDERING OF COEFFICIENTS:
C         A(0),B(0),A(1),B(1),A(2),B(2),...,A(N/2),B(N/2)
C         WHERE B(0)=B(N/2)=0; (N+2) LOCATIONS REQUIRED
C
C     ORDERING OF DATA:
C         X(N-1),X(0),X(1),X(2),...,X(N),X(0)
C         I.E. EXPLICIT CYCLIC CONTINUITY; (N+2) LOCATIONS REQUIRED
C
C     VECTORIZATION IS ACHIEVED ON CRAY BY DOING THE TRANSFORMS IN
C     PARALLEL
C
C     *** N.B. N IS ASSUMED TO BE AN EVEN NUMBER
C
C     DEFINITION OF TRANSFORMS:
C     -------------------------
C
C     ISIGN=+1: X(J)=SUM(K=0,...,N-1)(C(K)*EXP(2*I*J*K*PI/N))
C         WHERE C(K)=A(K)+I*B(K) AND C(N-K)=A(K)-I*B(K)
C
C     ISIGN=-1: A(K)=(1/N)*SUM(J=0,...,N-1)(X(J)*COS(2*J*K*PI/N))
C               B(K)=-(1/N)*SUM(J=0,...,N-1)(X(J)*SIN(2*J*K*PI/N))
C
C
C
C
      NFAX=IFAX(1)
      NX=N+1
      NH=N/2
      INK=INC+INC
      IF (ISIGN.EQ.+1) GO TO 30
C
C     IF NECESSARY, TRANSFER DATA TO WORK AREA
      IGO=50
      IF (MOD(NFAX,2).EQ.1) GOTO 40
      IBASE=INC+1
      JBASE=1
      DO 20 L=1,LOT
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 10 M=1,N
      WORK(J)=A(I)
      I=I+INC
      J=J+1
   10 CONTINUE
      IBASE=IBASE+JUMP
      JBASE=JBASE+NX
   20 CONTINUE
C
      IGO=60
      GO TO 40
C
C     PREPROCESSING (ISIGN=+1)
C     ------------------------
C
   30 CONTINUE
      CALL FFT99A(A,WORK,TRIGS,INC,JUMP,N,LOT)
      IGO=60
C
C     COMPLEX TRANSFORM
C     -----------------
C
   40 CONTINUE
      IA=INC+1
      LA=1
      DO 80 K=1,NFAX
      IF (IGO.EQ.60) GO TO 60
   50 CONTINUE
      CALL VPASSM(A(IA),A(IA+INC),WORK(1),WORK(2),TRIGS,
     *   INK,2,JUMP,NX,LOT,NH,IFAX(K+1),LA)
      IGO=60
      GO TO 70
   60 CONTINUE
      CALL VPASSM(WORK(1),WORK(2),A(IA),A(IA+INC),TRIGS,
     *    2,INK,NX,JUMP,LOT,NH,IFAX(K+1),LA)
      IGO=50
   70 CONTINUE
      LA=LA*IFAX(K+1)
   80 CONTINUE
C
      IF (ISIGN.EQ.-1) GO TO 130
C
C     IF NECESSARY, TRANSFER DATA FROM WORK AREA
      IF (MOD(NFAX,2).EQ.1) GO TO 110
      IBASE=1
      JBASE=IA
      DO 100 L=1,LOT
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 90 M=1,N
      A(J)=WORK(I)
      I=I+1
      J=J+INC
   90 CONTINUE
      IBASE=IBASE+NX
      JBASE=JBASE+JUMP
  100 CONTINUE
C
C     FILL IN CYCLIC BOUNDARY POINTS
  110 CONTINUE
      IA=1
      IB=N*INC+1
CDIR$ IVDEP
      DO 120 L=1,LOT
      A(IA)=A(IB)
      A(IB+INC)=A(IA+INC)
      IA=IA+JUMP
      IB=IB+JUMP
  120 CONTINUE
      GO TO 140
C
C     POSTPROCESSING (ISIGN=-1):
C     --------------------------
C
  130 CONTINUE
      CALL FFT99B(WORK,A,TRIGS,INC,JUMP,N,LOT)
C
  140 CONTINUE
      RETURN
      END
      SUBROUTINE FFT99A(A,WORK,TRIGS,INC,JUMP,N,LOT)
      DIMENSION A(JUMP*LOT),WORK((N+1)*LOT),TRIGS(3*N/2+1)
C
C     SUBROUTINE FFT99A - PREPROCESSING STEP FOR FFT99, ISIGN=+1
C     (SPECTRAL TO GRIDPOINT TRANSFORM)
C
      NH=N/2
      NX=N+1
      INK=INC+INC
C
C     A(0) AND A(N/2)
      IA=1
      IB=N*INC+1
      JA=1
      JB=2
CDIR$ IVDEP
      DO 10 L=1,LOT
      WORK(JA)=A(IA)+A(IB)
      WORK(JB)=A(IA)-A(IB)
      IA=IA+JUMP
      IB=IB+JUMP
      JA=JA+NX
      JB=JB+NX
   10 CONTINUE
C
C     REMAINING WAVENUMBERS
      IABASE=2*INC+1
      IBBASE=(N-2)*INC+1
      JABASE=3
      JBBASE=N-1
C
      DO 30 K=3,NH,2
      IA=IABASE
      IB=IBBASE
      JA=JABASE
      JB=JBBASE
      C=TRIGS(N+K)
      S=TRIGS(N+K+1)
CDIR$ IVDEP
      DO 20 L=1,LOT
      WORK(JA)=(A(IA)+A(IB))-
     *    (S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC)))
      WORK(JB)=(A(IA)+A(IB))+
     *    (S*(A(IA)-A(IB))+C*(A(IA+INC)+A(IB+INC)))
      WORK(JA+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))+
     *    (A(IA+INC)-A(IB+INC))
      WORK(JB+1)=(C*(A(IA)-A(IB))-S*(A(IA+INC)+A(IB+INC)))-
     *    (A(IA+INC)-A(IB+INC))
      IA=IA+JUMP
      IB=IB+JUMP
      JA=JA+NX
      JB=JB+NX
   20 CONTINUE
      IABASE=IABASE+INK
      IBBASE=IBBASE-INK
      JABASE=JABASE+2
      JBBASE=JBBASE-2
   30 CONTINUE
C
      IF (IABASE.NE.IBBASE) GO TO 50
C     WAVENUMBER N/4 (IF IT EXISTS)
      IA=IABASE
      JA=JABASE
CDIR$ IVDEP
      DO 40 L=1,LOT
      WORK(JA)=2.0*A(IA)
      WORK(JA+1)=-2.0*A(IA+INC)
      IA=IA+JUMP
      JA=JA+NX
   40 CONTINUE
C
   50 CONTINUE
      RETURN
      END
      SUBROUTINE FFT99B(WORK,A,TRIGS,INC,JUMP,N,LOT)
      DIMENSION WORK((N+1)*LOT),A(JUMP*LOT),TRIGS(3*N/2+1)
C
C     SUBROUTINE FFT99B - POSTPROCESSING STEP FOR FFT99, ISIGN=-1
C     (GRIDPOINT TO SPECTRAL TRANSFORM)
C
      NH=N/2
      NX=N+1
      INK=INC+INC
C
C     A(0) AND A(N/2)
      SCALE=1.0/FLOAT(N)
      IA=1
      IB=2
      JA=1
      JB=N*INC+1
CDIR$ IVDEP
      DO 10 L=1,LOT
      A(JA)=SCALE*(WORK(IA)+WORK(IB))
      A(JB)=SCALE*(WORK(IA)-WORK(IB))
      A(JA+INC)=0.0
      A(JB+INC)=0.0
      IA=IA+NX
      IB=IB+NX
      JA=JA+JUMP
      JB=JB+JUMP
   10 CONTINUE
C
C     REMAINING WAVENUMBERS
      SCALE=0.5*SCALE
      IABASE=3
      IBBASE=N-1
      JABASE=2*INC+1
      JBBASE=(N-2)*INC+1
C
      DO 30 K=3,NH,2
      IA=IABASE
      IB=IBBASE
      JA=JABASE
      JB=JBBASE
      C=TRIGS(N+K)
      S=TRIGS(N+K+1)
CDIR$ IVDEP
      DO 20 L=1,LOT
      A(JA)=SCALE*((WORK(IA)+WORK(IB))
     *   +(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB))))
      A(JB)=SCALE*((WORK(IA)+WORK(IB))
     *   -(C*(WORK(IA+1)+WORK(IB+1))+S*(WORK(IA)-WORK(IB))))
      A(JA+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1)))
     *    +(WORK(IB+1)-WORK(IA+1)))
      A(JB+INC)=SCALE*((C*(WORK(IA)-WORK(IB))-S*(WORK(IA+1)+WORK(IB+1)))
     *    -(WORK(IB+1)-WORK(IA+1)))
      IA=IA+NX
      IB=IB+NX
      JA=JA+JUMP
      JB=JB+JUMP
   20 CONTINUE
      IABASE=IABASE+2
      IBBASE=IBBASE-2
      JABASE=JABASE+INK
      JBBASE=JBBASE-INK
   30 CONTINUE
C
      IF (IABASE.NE.IBBASE) GO TO 50
C     WAVENUMBER N/4 (IF IT EXISTS)
      IA=IABASE
      JA=JABASE
      SCALE=2.0*SCALE
CDIR$ IVDEP
      DO 40 L=1,LOT
      A(JA)=SCALE*WORK(IA)
      A(JA+INC)=-SCALE*WORK(IA+1)
      IA=IA+NX
      JA=JA+JUMP
   40 CONTINUE
C
   50 CONTINUE
      RETURN
      END
      SUBROUTINE FFT991(A,WORK,TRIGS,IFAX,INC,JUMP,N,LOT,ISIGN)
      DIMENSION A(JUMP*LOT),WORK((N+1)*LOT),TRIGS(3*N/2+1),IFAX(13)
C
C     SUBROUTINE "FFT991" - MULTIPLE REAL/HALF-COMPLEX PERIODIC
C     FAST FOURIER TRANSFORM
C
C     SAME AS FFT99 EXCEPT THAT ORDERING OF DATA CORRESPONDS TO
C     THAT IN MRFFT2
C
C     PROCEDURE USED TO CONVERT TO HALF-LENGTH COMPLEX TRANSFORM
C     IS GIVEN BY COOLEY, LEWIS AND WELCH (J. SOUND VIB., VOL. 12
C     (1970), 315-337)
C
C     A IS THE ARRAY CONTAINING INPUT AND OUTPUT DATA
C     WORK IS AN AREA OF SIZE (N+1)*LOT
C     TRIGS IS A PREVIOUSLY PREPARED LIST OF TRIG FUNCTION VALUES
C     IFAX IS A PREVIOUSLY PREPARED LIST OF FACTORS OF N/2
C     INC IS THE INCREMENT WITHIN EACH DATA 'VECTOR'
C         (E.G. INC=1 FOR CONSECUTIVELY STORED DATA)
C     JUMP IS THE INCREMENT BETWEEN THE START OF EACH DATA VECTOR
C     N IS THE LENGTH OF THE DATA VECTORS
C     LOT IS THE NUMBER OF DATA VECTORS
C     ISIGN = +1 FOR TRANSFORM FROM SPECTRAL TO GRIDPOINT
C           = -1 FOR TRANSFORM FROM GRIDPOINT TO SPECTRAL
C
C     ORDERING OF COEFFICIENTS:
C         A(0),B(0),A(1),B(1),A(2),B(2),...,A(N/2),B(N/2)
C         WHERE B(0)=B(N/2)=0; (N+2) LOCATIONS REQUIRED
C
C     ORDERING OF DATA:
C         X(0),X(1),X(2),...,X(N-1)
C
C     VECTORIZATION IS ACHIEVED ON CRAY BY DOING THE TRANSFORMS IN
C     PARALLEL
C
C     *** N.B. N IS ASSUMED TO BE AN EVEN NUMBER
C
C     DEFINITION OF TRANSFORMS:
C     -------------------------
C
C     ISIGN=+1: X(J)=SUM(K=0,...,N-1)(C(K)*EXP(2*I*J*K*PI/N))
C         WHERE C(K)=A(K)+I*B(K) AND C(N-K)=A(K)-I*B(K)
C
C     ISIGN=-1: A(K)=(1/N)*SUM(J=0,...,N-1)(X(J)*COS(2*J*K*PI/N))
C               B(K)=-(1/N)*SUM(J=0,...,N-1)(X(J)*SIN(2*J*K*PI/N))
C
C
C
      NFAX=IFAX(1)
      NX=N+1
      NH=N/2
      INK=INC+INC
      IF (ISIGN.EQ.+1) GO TO 30
C
C     IF NECESSARY, TRANSFER DATA TO WORK AREA
      IGO=50
      IF (MOD(NFAX,2).EQ.1) GOTO 40
      IBASE=1
      JBASE=1
      DO 20 L=1,LOT
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 10 M=1,N
      WORK(J)=A(I)
      I=I+INC
      J=J+1
   10 CONTINUE
      IBASE=IBASE+JUMP
      JBASE=JBASE+NX
   20 CONTINUE
C
      IGO=60
      GO TO 40
C
C     PREPROCESSING (ISIGN=+1)
C     ------------------------
C
   30 CONTINUE
      CALL FFT99A(A,WORK,TRIGS,INC,JUMP,N,LOT)
      IGO=60
C
C     COMPLEX TRANSFORM
C     -----------------
C
   40 CONTINUE
      IA=1
      LA=1
      DO 80 K=1,NFAX
      IF (IGO.EQ.60) GO TO 60
   50 CONTINUE
      CALL VPASSM(A(IA),A(IA+INC),WORK(1),WORK(2),TRIGS,
     *   INK,2,JUMP,NX,LOT,NH,IFAX(K+1),LA)
      IGO=60
      GO TO 70
   60 CONTINUE
      CALL VPASSM(WORK(1),WORK(2),A(IA),A(IA+INC),TRIGS,
     *    2,INK,NX,JUMP,LOT,NH,IFAX(K+1),LA)
      IGO=50
   70 CONTINUE
      LA=LA*IFAX(K+1)
   80 CONTINUE
C
      IF (ISIGN.EQ.-1) GO TO 130
C
C     IF NECESSARY, TRANSFER DATA FROM WORK AREA
      IF (MOD(NFAX,2).EQ.1) GO TO 110
      IBASE=1
      JBASE=1
      DO 100 L=1,LOT
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 90 M=1,N
      A(J)=WORK(I)
      I=I+1
      J=J+INC
   90 CONTINUE
      IBASE=IBASE+NX
      JBASE=JBASE+JUMP
  100 CONTINUE
C
C     FILL IN ZEROS AT END
  110 CONTINUE
      IB=N*INC+1
CDIR$ IVDEP
      DO 120 L=1,LOT
      A(IB)=0.0
      A(IB+INC)=0.0
      IB=IB+JUMP
  120 CONTINUE
      GO TO 140
C
C     POSTPROCESSING (ISIGN=-1):
C     --------------------------
C
  130 CONTINUE
      CALL FFT99B(WORK,A,TRIGS,INC,JUMP,N,LOT)
C
  140 CONTINUE
      RETURN
      END
      SUBROUTINE SET99 (TRIGS, IFAX, N)
      DIMENSION IFAX(13),TRIGS(3*N/2+1)
C
C MODE 3 IS USED FOR REAL/HALF-COMPLEX TRANSFORMS.  IT IS POSSIBLE
C TO DO COMPLEX/COMPLEX TRANSFORMS WITH OTHER VALUES OF MODE, BUT
C DOCUMENTATION OF THE DETAILS WERE NOT AVAILABLE WHEN THIS ROUTINE
C WAS WRITTEN.
C
      DATA MODE /3/
      CALL FAX (IFAX, N, MODE)
      I = IFAX(1)
      IF (IFAX(I+1) .GT. 5 .OR. N .LE. 4) IFAX(1) = -99
      IF (IFAX(1) .LE. 0 ) THEN
        WRITE(6,*) ' SET99 -- INVALID N'
        STOP'SET99'
      ENDIF
      CALL FFTRIG (TRIGS, N, MODE)
      RETURN
      END
      SUBROUTINE FAX(IFAX,N,MODE)
      DIMENSION IFAX(13)
      NN=N
      IF (IABS(MODE).EQ.1) GO TO 10
      IF (IABS(MODE).EQ.8) GO TO 10
      NN=N/2
      IF ((NN+NN).EQ.N) GO TO 10
      IFAX(1)=-99
      RETURN
   10 K=1
C     TEST FOR FACTORS OF 4
   20 IF (MOD(NN,4).NE.0) GO TO 30
      K=K+1
      IFAX(K)=4
      NN=NN/4
      IF (NN.EQ.1) GO TO 80
      GO TO 20
C     TEST FOR EXTRA FACTOR OF 2
   30 IF (MOD(NN,2).NE.0) GO TO 40
      K=K+1
      IFAX(K)=2
      NN=NN/2
      IF (NN.EQ.1) GO TO 80
C     TEST FOR FACTORS OF 3
   40 IF (MOD(NN,3).NE.0) GO TO 50
      K=K+1
      IFAX(K)=3
      NN=NN/3
      IF (NN.EQ.1) GO TO 80
      GO TO 40
C     NOW FIND REMAINING FACTORS
   50 L=5
      INC=2
C     INC ALTERNATELY TAKES ON VALUES 2 AND 4
   60 IF (MOD(NN,L).NE.0) GO TO 70
      K=K+1
      IFAX(K)=L
      NN=NN/L
      IF (NN.EQ.1) GO TO 80
      GO TO 60
   70 L=L+INC
      INC=6-INC
      GO TO 60
   80 IFAX(1)=K-1
C     IFAX(1) CONTAINS NUMBER OF FACTORS
      NFAX=IFAX(1)
C     SORT FACTORS INTO ASCENDING ORDER
      IF (NFAX.EQ.1) GO TO 110
      DO 100 II=2,NFAX
      ISTOP=NFAX+2-II
      DO 90 I=2,ISTOP
      IF (IFAX(I+1).GE.IFAX(I)) GO TO 90
      ITEM=IFAX(I)
      IFAX(I)=IFAX(I+1)
      IFAX(I+1)=ITEM
   90 CONTINUE
  100 CONTINUE
  110 CONTINUE
      RETURN
      END
      SUBROUTINE FFTRIG(TRIGS,N,MODE)
      DIMENSION TRIGS(3*N/2+1)
      PI=2.0*ASIN(1.0)
      IMODE=IABS(MODE)
      NN=N
      IF (IMODE.GT.1.AND.IMODE.LT.6) NN=N/2
      DEL=(PI+PI)/FLOAT(NN)
      L=NN+NN
      DO 10 I=1,L,2
      ANGLE=0.5*FLOAT(I-1)*DEL
      TRIGS(I)=COS(ANGLE)
      TRIGS(I+1)=SIN(ANGLE)
   10 CONTINUE
      IF (IMODE.EQ.1) RETURN
      IF (IMODE.EQ.8) RETURN
      DEL=0.5*DEL
      NH=(NN+1)/2
      L=NH+NH
      LA=NN+NN
      DO 20 I=1,L,2
      ANGLE=0.5*FLOAT(I-1)*DEL
      TRIGS(LA+I)=COS(ANGLE)
      TRIGS(LA+I+1)=SIN(ANGLE)
   20 CONTINUE
      IF (IMODE.LE.3) RETURN
      DEL=0.5*DEL
      LA=LA+NN
      IF (MODE.EQ.5) GO TO 40
      DO 30 I=2,NN
      ANGLE=FLOAT(I-1)*DEL
      TRIGS(LA+I)=2.0*SIN(ANGLE)
   30 CONTINUE
      RETURN
   40 CONTINUE
      DEL=0.5*DEL
      DO 50 I=2,N
      ANGLE=FLOAT(I-1)*DEL
      TRIGS(LA+I)=SIN(ANGLE)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE VPASSM(A,B,C,D,TRIGS,INC1,INC2,INC3,INC4,LOT,N,IFAC,LA)
      DIMENSION A((N+1)*2*LOT),B((N+1)*2*LOT),
     &          C((N+1)*2*LOT),D((N+1)*2*LOT),
     &          TRIGS(3*N/2+1)
C
C     SUBROUTINE "VPASSM" - MULTIPLE VERSION OF "VPASSA"
C     PERFORMS ONE PASS THROUGH DATA
C     AS PART OF MULTIPLE COMPLEX FFT ROUTINE
C     A IS FIRST REAL INPUT VECTOR
C     B IS FIRST IMAGINARY INPUT VECTOR
C     C IS FIRST REAL OUTPUT VECTOR
C     D IS FIRST IMAGINARY OUTPUT VECTOR
C     TRIGS IS PRECALCULATED TABLE OF SINES " COSINES
C     INC1 IS ADDRESSING INCREMENT FOR A AND B
C     INC2 IS ADDRESSING INCREMENT FOR C AND D
C     INC3 IS ADDRESSING INCREMENT BETWEEN A"S & B"S
C     INC4 IS ADDRESSING INCREMENT BETWEEN C"S & D"S
C     LOT IS THE NUMBER OF VECTORS
C     N IS LENGTH OF VECTORS
C     IFAC IS CURRENT FACTOR OF N
C     LA IS PRODUCT OF PREVIOUS FACTORS
C
      DATA SIN36/0.587785252292473/,COS36/0.809016994374947/,
     *     SIN72/0.951056516295154/,COS72/0.309016994374947/,
     *     SIN60/0.866025403784437/
C
      M=N/IFAC
      IINK=M*INC1
      JINK=LA*INC2
      JUMP=(IFAC-1)*JINK
      IBASE=0
      JBASE=0
      IGO=IFAC-1
      IF (IGO.GT.4) RETURN
      GO TO (10,50,90,130),IGO
C
C     CODING FOR FACTOR 2
C
   10 IA=1
      JA=1
      IB=IA+IINK
      JB=JA+JINK
      DO 20 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 15 IJK=1,LOT
      C(JA+J)=A(IA+I)+A(IB+I)
      D(JA+J)=B(IA+I)+B(IB+I)
      C(JB+J)=A(IA+I)-A(IB+I)
      D(JB+J)=B(IA+I)-B(IB+I)
      I=I+INC3
      J=J+INC4
   15 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
   20 CONTINUE
      IF (LA.EQ.M) RETURN
      LA1=LA+1
      JBASE=JBASE+JUMP
      DO 40 K=LA1,M,LA
      KB=K+K-2
      C1=TRIGS(KB+1)
      S1=TRIGS(KB+2)
      DO 30 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 25 IJK=1,LOT
      C(JA+J)=A(IA+I)+A(IB+I)
      D(JA+J)=B(IA+I)+B(IB+I)
      C(JB+J)=C1*(A(IA+I)-A(IB+I))-S1*(B(IA+I)-B(IB+I))
      D(JB+J)=S1*(A(IA+I)-A(IB+I))+C1*(B(IA+I)-B(IB+I))
      I=I+INC3
      J=J+INC4
   25 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
   30 CONTINUE
      JBASE=JBASE+JUMP
   40 CONTINUE
      RETURN
C
C     CODING FOR FACTOR 3
C
   50 IA=1
      JA=1
      IB=IA+IINK
      JB=JA+JINK
      IC=IB+IINK
      JC=JB+JINK
      DO 60 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 55 IJK=1,LOT
      C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I))
      D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I))
      C(JB+J)=(A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I)))
      C(JC+J)=(A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I)))
      D(JB+J)=(B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I)))
      D(JC+J)=(B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I)))
      I=I+INC3
      J=J+INC4
   55 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
   60 CONTINUE
      IF (LA.EQ.M) RETURN
      LA1=LA+1
      JBASE=JBASE+JUMP
      DO 80 K=LA1,M,LA
      KB=K+K-2
      KC=KB+KB
      C1=TRIGS(KB+1)
      S1=TRIGS(KB+2)
      C2=TRIGS(KC+1)
      S2=TRIGS(KC+2)
      DO 70 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 65 IJK=1,LOT
      C(JA+J)=A(IA+I)+(A(IB+I)+A(IC+I))
      D(JA+J)=B(IA+I)+(B(IB+I)+B(IC+I))
      C(JB+J)=
     *    C1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I))))
     *   -S1*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I))))
      D(JB+J)=
     *    S1*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))-(SIN60*(B(IB+I)-B(IC+I))))
     *   +C1*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))+(SIN60*(A(IB+I)-A(IC+I))))
      C(JC+J)=
     *    C2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I))))
     *   -S2*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I))))
      D(JC+J)=
     *    S2*((A(IA+I)-0.5*(A(IB+I)+A(IC+I)))+(SIN60*(B(IB+I)-B(IC+I))))
     *   +C2*((B(IA+I)-0.5*(B(IB+I)+B(IC+I)))-(SIN60*(A(IB+I)-A(IC+I))))
      I=I+INC3
      J=J+INC4
   65 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
   70 CONTINUE
      JBASE=JBASE+JUMP
   80 CONTINUE
      RETURN
C
C     CODING FOR FACTOR 4
C
   90 IA=1
      JA=1
      IB=IA+IINK
      JB=JA+JINK
      IC=IB+IINK
      JC=JB+JINK
      ID=IC+IINK
      JD=JC+JINK
      DO 100 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 95 IJK=1,LOT
      C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I))
      C(JC+J)=(A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I))
      D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I))
      D(JC+J)=(B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I))
      C(JB+J)=(A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I))
      C(JD+J)=(A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I))
      D(JB+J)=(B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I))
      D(JD+J)=(B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I))
      I=I+INC3
      J=J+INC4
   95 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  100 CONTINUE
      IF (LA.EQ.M) RETURN
      LA1=LA+1
      JBASE=JBASE+JUMP
      DO 120 K=LA1,M,LA
      KB=K+K-2
      KC=KB+KB
      KD=KC+KB
      C1=TRIGS(KB+1)
      S1=TRIGS(KB+2)
      C2=TRIGS(KC+1)
      S2=TRIGS(KC+2)
      C3=TRIGS(KD+1)
      S3=TRIGS(KD+2)
      DO 110 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 105 IJK=1,LOT
      C(JA+J)=(A(IA+I)+A(IC+I))+(A(IB+I)+A(ID+I))
      D(JA+J)=(B(IA+I)+B(IC+I))+(B(IB+I)+B(ID+I))
      C(JC+J)=
     *    C2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I)))
     *   -S2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I)))
      D(JC+J)=
     *    S2*((A(IA+I)+A(IC+I))-(A(IB+I)+A(ID+I)))
     *   +C2*((B(IA+I)+B(IC+I))-(B(IB+I)+B(ID+I)))
      C(JB+J)=
     *    C1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I)))
     *   -S1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I)))
      D(JB+J)=
     *    S1*((A(IA+I)-A(IC+I))-(B(IB+I)-B(ID+I)))
     *   +C1*((B(IA+I)-B(IC+I))+(A(IB+I)-A(ID+I)))
      C(JD+J)=
     *    C3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I)))
     *   -S3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I)))
      D(JD+J)=
     *    S3*((A(IA+I)-A(IC+I))+(B(IB+I)-B(ID+I)))
     *   +C3*((B(IA+I)-B(IC+I))-(A(IB+I)-A(ID+I)))
      I=I+INC3
      J=J+INC4
  105 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  110 CONTINUE
      JBASE=JBASE+JUMP
  120 CONTINUE
      RETURN
C
C     CODING FOR FACTOR 5
C
  130 IA=1
      JA=1
      IB=IA+IINK
      JB=JA+JINK
      IC=IB+IINK
      JC=JB+JINK
      ID=IC+IINK
      JD=JC+JINK
      IE=ID+IINK
      JE=JD+JINK
      DO 140 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 135 IJK=1,LOT
      C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I))
      D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I))
      C(JB+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I)))
     *  -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))
      C(JE+J)=(A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I)))
     *  +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I)))
      D(JB+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I)))
     *  +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))
      D(JE+J)=(B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I)))
     *  -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I)))
      C(JC+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I)))
     *  -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))
      C(JD+J)=(A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I)))
     *  +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I)))
      D(JC+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I)))
     *  +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))
      D(JD+J)=(B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I)))
     *  -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I)))
      I=I+INC3
      J=J+INC4
  135 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  140 CONTINUE
      IF (LA.EQ.M) RETURN
      LA1=LA+1
      JBASE=JBASE+JUMP
      DO 160 K=LA1,M,LA
      KB=K+K-2
      KC=KB+KB
      KD=KC+KB
      KE=KD+KB
      C1=TRIGS(KB+1)
      S1=TRIGS(KB+2)
      C2=TRIGS(KC+1)
      S2=TRIGS(KC+2)
      C3=TRIGS(KD+1)
      S3=TRIGS(KD+2)
      C4=TRIGS(KE+1)
      S4=TRIGS(KE+2)
      DO 150 L=1,LA
      I=IBASE
      J=JBASE
CDIR$ IVDEP
      DO 145 IJK=1,LOT
      C(JA+J)=A(IA+I)+(A(IB+I)+A(IE+I))+(A(IC+I)+A(ID+I))
      D(JA+J)=B(IA+I)+(B(IB+I)+B(IE+I))+(B(IC+I)+B(ID+I))
      C(JB+J)=
     *    C1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I)))
     *      -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))))
     *   -S1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I)))
     *      +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))))
      D(JB+J)=
     *    S1*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I)))
     *      -(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))))
     *   +C1*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I)))
     *      +(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))))
      C(JE+J)=
     *    C4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I)))
     *      +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))))
     *   -S4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I)))
     *      -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))))
      D(JE+J)=
     *    S4*((A(IA+I)+COS72*(A(IB+I)+A(IE+I))-COS36*(A(IC+I)+A(ID+I)))
     *      +(SIN72*(B(IB+I)-B(IE+I))+SIN36*(B(IC+I)-B(ID+I))))
     *   +C4*((B(IA+I)+COS72*(B(IB+I)+B(IE+I))-COS36*(B(IC+I)+B(ID+I)))
     *      -(SIN72*(A(IB+I)-A(IE+I))+SIN36*(A(IC+I)-A(ID+I))))
      C(JC+J)=
     *    C2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I)))
     *      -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))))
     *   -S2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I)))
     *      +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))))
      D(JC+J)=
     *    S2*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I)))
     *      -(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))))
     *   +C2*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I)))
     *      +(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))))
      C(JD+J)=
     *    C3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I)))
     *      +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))))
     *   -S3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I)))
     *      -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))))
      D(JD+J)=
     *    S3*((A(IA+I)-COS36*(A(IB+I)+A(IE+I))+COS72*(A(IC+I)+A(ID+I)))
     *      +(SIN36*(B(IB+I)-B(IE+I))-SIN72*(B(IC+I)-B(ID+I))))
     *   +C3*((B(IA+I)-COS36*(B(IB+I)+B(IE+I))+COS72*(B(IC+I)+B(ID+I)))
     *      -(SIN36*(A(IB+I)-A(IE+I))-SIN72*(A(IC+I)-A(ID+I))))
      I=I+INC3
      J=J+INC4
  145 CONTINUE
      IBASE=IBASE+INC1
      JBASE=JBASE+INC2
  150 CONTINUE
      JBASE=JBASE+JUMP
  160 CONTINUE
      RETURN
      END


! Write a 100x100 matrix of random real numbers to a file.
PROGRAM write_data
IMPLICIT NONE
  INTEGER, PARAMETER :: ROWS = 100, COLS = 100
  INTEGER, DIMENSION(8) :: time
  INTEGER :: i, j
  CHARACTER(LEN=3) :: col_str
  CHARACTER(LEN=9) :: fmt

  CALL DATE_AND_TIME(VALUES=time)
  CALL SRAND(time(8))

  WRITE(col_str, '(I3)') COLS
  col_str = TRIM(col_str)
  fmt = '(' // col_str // 'F8.1)'

  OPEN (1, FILE='data.txt', STATUS='NEW', ACTION='WRITE')
  WRITE(1,'(2I5)') ROWS, COLS
  WRITE (1, fmt) ((RAND() * 1000. - 500., j=1,COLS), i=1,ROWS)

END PROGRAM write_data


      real*8 function xsin(x)
      implicit none
      real*8 x,x2
      if(abs(x) .gt. .1d0)then
        xsin=x-sin(x)
      else
        x2=x**2
        xsin=x*x2/6.d0*(1.d0-x2/20.d0*(1.d0-x2/42.d0*(
     1       1.d0-x2/72.d0*(1.d0-x2/110.d0))))
      endif
      return
      end

      real*8 function xsinh(x)
      implicit none
      real*8 x,x2
      if(abs(x) .gt. .1d0)then
        xsinh=x-sinh(x)
      else
        x2=x**2
        xsinh=-x*x2/6.d0*(1.d0+x2/20.d0*(1.d0+x2/42.d0*(
     1       1.d0+x2/72.d0*(1.d0+x2/110.d0))))
      endif
      return
      end

      real*8 function xlog(x)
      implicit none
      real*8 x
      if(abs(x) .gt. 1.d-2)then
        xlog=log(1.d0+x)
      else
        xlog=x*(1.d0-x*(.5d0-x*(1.d0/3.d0
     1      -x*(.25d0-x*(.2d0-x*(1.d0/6.d0
     1      -x*(1.d0/7.d0-x*(.125d0-x/9.d0))))))))
      endif
      return
      end

      real*8 function sinc(x)
      implicit none
      real*8 x,x2
      if(abs(x) .gt. .1d0)then
        sinc=x*cos(x)-sin(x)
      else
        x2=x**2
        sinc=-x*x2/6.d0*(2.d0-x2/20.d0*(4.d0-x2/42.d0*(
     1       6.d0-x2/72.d0*(8.d0-x2/11.d0))))
      endif
      return
      end

      real*8 function sinhc(x)
      implicit none
      real*8 x,x2
      if(abs(x) .gt. .1d0)then
        sinhc=x*cosh(x)-sinh(x)
      else
        x2=x**2
        sinhc=x*x2/6.d0*(2.d0+x2/20.d0*(4.d0+x2/42.d0*(
     1       6.d0+x2/72.d0*(8.d0+x2/11.d0))))
      endif
      return
      end


module angular_functions_module

use system_module
use units_module
use linearalgebra_module

implicit none
private

   real(dp), dimension(:,:,:,:,:,:), allocatable, save :: cg_array
   integer, save :: cg_j1_max=0, cg_m1_max=0, cg_j2_max=0, cg_m2_max=0, cg_j_max=0, cg_m_max=0
   logical, save :: cg_initialised = .false.

   public :: SphericalYCartesian, GradSphericalYCartesian
   public :: SphericalYCartesian_all, GradSphericalYCartesian_all
   public :: SolidRCartesian

   public :: wigner3j
   public :: cg_initialise, cg_finalise, cg_array

contains

   !#################################################################################
   !#
   !% Solid Harmonic function using Cartesian coordinates
   !%
   !% $ R_{l m} = \sqrt{\frac{4 \pi}{2 l + 1}} r^l Y_{l m} $
   !#
   !#################################################################################

   function SolidRCartesian(l, m, x)

     complex(dp) :: SolidRCartesian
     integer, intent(in) :: l, m
     real(dp), intent(in) :: x(3)
     integer :: p, q, s

     SolidRCartesian = CPLX_ZERO

     do p = 0, l
        q = p - m
        s = l - p - q

        if ((q >= 0) .and. (s >= 0)) then
           SolidRCartesian = SolidRCartesian + ((cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp)**p) &
                                             * (cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp)**q) &
                                             * (x(3)**s) &
                                             / (factorial(p) * factorial(q) * factorial(s)))
        end if
     end do

     SolidRCartesian = SolidRCartesian * sqrt(factorial(l + m) * factorial(l - m))

   end function SolidRCartesian

   function SolidRCartesian_all(l_max, x)

     integer, intent(in) :: l_max
     real(dp), intent(in) :: x(3)
     complex(dp) :: SolidRCartesian_all(0:l_max, -l_max:l_max)

     integer :: l, m
     integer :: p, q, s
     complex(kind=dp) :: cm, cp, cm_term(0:l_max), cp_term(0:2*l_max), x3_term(0:2*l_max)
     real(dp) :: factorials(0:2*l_max)

     SolidRCartesian_all = CPLX_ZERO

     cm = cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp)
     cp = cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp)

     ! p = 0 .. l
     do p=0, l_max
         cm_term(p) = cm**p
     end do
     ! q, s = 0 .. 2l
     do q=0, 2*l_max
        cp_term(q) = cp**q
        x3_term(q) = x(3)**q
        factorials(q) = factorial(q)
     end do

     do l=0, l_max
     do m=-l, l
         do p = 0, l
            q = p - m
            s = l - p - q

            if ((q >= 0) .and. (s >= 0)) then
               SolidRCartesian_all(l,m) = SolidRCartesian_all(l,m) + &
                ( cm_term(p) * cp_term(q) * x3_term(s) / &
                  ( factorials(p) * factorials(q) * factorials(s) ) )
            end if
         end do

         SolidRCartesian_all(l,m) = SolidRCartesian_all(l,m) * sqrt(factorials(l + m) * factorials(l - m))
     end do
     end do

   end function SolidRCartesian_all

   !#################################################################################
   !#
   !% Spherical Harmonic function using Cartesian coordinates
   !#
   !#################################################################################

   function SphericalYCartesian(l, m, x)

     complex(dp) :: SphericalYCartesian
     integer, intent(in) :: l, m
     real(dp), intent(in) :: x(3)

     SphericalYCartesian = SolidRCartesian(l, m, x) * sqrt(((2.0_dp * l) + 1) / (4.0_dp * PI)) &
                                                    * (normsq(x)**(-0.5_dp * l))

   end function SphericalYCartesian

   function SphericalYCartesian_all(l_max, x)

     integer, intent(in) :: l_max
     real(dp), intent(in) :: x(3)
     complex(dp) :: SphericalYCartesian_all(0:l_max, -l_max:l_max)

     real(dp) :: normsq_x
     integer :: l, m

     normsq_x = normsq(x)
     SphericalYCartesian_all = SolidRCartesian_all(l_max, x)
     do l=0, l_max
         SphericalYCartesian_all(l,-l:l) = SphericalYCartesian_all(l,-l:l) * &
            sqrt(((2.0_dp * l) + 1) / (4.0_dp * PI)) * (normsq_x**(-0.5_dp * l))
     end do

   end function SphericalYCartesian_all

    !#################################################################################
    !#
    !% Derivative of Spherical Harmonic function using Cartesian coordinates
    !#
    !#################################################################################

    function GradSphericalYCartesian(l, m, x)

      complex(dp) :: GradSphericalYCartesian(3)
      integer, intent(in) :: l, m
      real(dp), intent(in) :: x(3)
      integer :: p, q, s

      GradSphericalYCartesian = CPLX_ZERO

      do p = 0, l
         q = p - m
         s = l - p - q

         if ((p >= 1) .and. (q >= 0) .and. (s >= 0)) then
            GradSphericalYCartesian(1) = GradSphericalYCartesian(1) &
                                       - ((cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp)**(p - 1)) &
                                       * (cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp)**q) &
                                       * (x(3)**s) &
                                       * 0.5_dp &
                                       / (factorial(p - 1) * factorial(q) * factorial(s)))
            GradSphericalYCartesian(2) = GradSphericalYCartesian(2) &
                                       - ((cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp)**(p - 1)) &
                                       * (cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp)**q) &
                                       * (x(3)**s) &
                                       * 0.5_dp * cmplx(0.0_dp, 1.0_dp, dp) &
                                       / (factorial(p - 1) * factorial(q) * factorial(s)))
         end if

         if ((p >= 0) .and. (q >= 1) .and. (s >= 0)) then
            GradSphericalYCartesian(1) = GradSphericalYCartesian(1) &
                                       + ((cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp)**p) &
                                       * (cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp)**(q - 1)) &
                                       * (x(3)**s) &
                                       * 0.5_dp &
                                       / (factorial(p) * factorial(q - 1) * factorial(s)))
            GradSphericalYCartesian(2) = GradSphericalYCartesian(2) &
                                       - ((cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp)**p) &
                                       * (cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp)**(q - 1)) &
                                       * (x(3)**s) &
                                       * 0.5_dp * cmplx(0.0_dp, 1.0_dp, dp) &
                                       / (factorial(p) * factorial(q - 1) * factorial(s)))
         end if

         if ((p >= 0) .and. (q >= 0) .and. (s >= 1)) then
            GradSphericalYCartesian(3) = GradSphericalYCartesian(3) &
                                       + ((cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp)**p) &
                                       * (cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp)**q) &
                                       * (x(3)**(s - 1)) &
                                       / (factorial(p) * factorial(q) * factorial(s - 1)))
         end if
      end do

      GradSphericalYCartesian = GradSphericalYCartesian &
                              * sqrt(factorial(l + m) * factorial(l - m) * ((2.0_dp * l) + 1) / (4.0_dp * PI)) &
                              * (normsq(x)**(-0.5_dp * l))

      GradSphericalYCartesian = GradSphericalYCartesian &
                              - (l * x * SphericalYCartesian(l, m, x) / normsq(x))

    end function GradSphericalYCartesian

    function GradSphericalYCartesian_all(l_max, x)

      integer, intent(in) :: l_max
      real(dp), intent(in) :: x(3)
      complex(dp) :: GradSphericalYCartesian_all(0:l_max, -l_max:l_max, 3)

      integer :: l, m
      integer :: p, q, s
      complex(kind=dp) :: cm, cp, cm_term(0:l_max), cp_term(0:2*l_max), x3_term(0:2*l_max)
      real(dp) :: factorials(0:2*l_max)
      real(dp) :: normsq_x
      complex(dp) :: tt

      GradSphericalYCartesian_all = CPLX_ZERO

      cm = cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp)
      cp = cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp)

      ! p = 0 .. l
      do p=0, l_max
          cm_term(p) = cm**p
      end do
      ! q, s = 0 .. 2l
      do q=0, 2*l_max
         cp_term(q) = cp**q
         x3_term(q) = x(3)**q
         factorials(q) = factorial(q)
      end do

      normsq_x = normsq(x)

      do l=0, l_max
      do m=-l, l
          do p = 0, l
             q = p - m
             s = l - p - q

             if ((p >= 1) .and. (q >= 0) .and. (s >= 0)) then
                tt = (cm_term(p-1) * cp_term(q) * x3_term(s) &
                      * 0.5_dp &
                      / (factorials(p - 1) * factorials(q) * factorials(s)))
                GradSphericalYCartesian_all(l,m,1) = GradSphericalYCartesian_all(l,m,1) &
                                           - tt
                GradSphericalYCartesian_all(l,m,2) = GradSphericalYCartesian_all(l,m,2) &
                                           - tt * cmplx(0.0_dp, 1.0_dp, dp)
             end if

             if ((p >= 0) .and. (q >= 1) .and. (s >= 0)) then
                tt = (cm_term(p) * cp_term(q-1) * x3_term(s) &
                      * 0.5_dp &
                      / (factorials(p) * factorials(q - 1) * factorials(s)))
                GradSphericalYCartesian_all(l,m,1) = GradSphericalYCartesian_all(l,m,1) &
                                           + tt
                GradSphericalYCartesian_all(l,m,2) = GradSphericalYCartesian_all(l,m,2) &
                                           - tt * cmplx(0.0_dp, 1.0_dp, dp)
             end if

             if ((p >= 0) .and. (q >= 0) .and. (s >= 1)) then
                GradSphericalYCartesian_all(l,m,3) = GradSphericalYCartesian_all(l,m,3) &
                                           + (cm_term(p) * cp_term(q) * x3_term(s-1) &
                                           / (factorials(p) * factorials(q) * factorials(s - 1)))
             end if
          end do

          GradSphericalYCartesian_all(l,m,:) = GradSphericalYCartesian_all(l,m,:) &
                                  * sqrt(factorials(l + m) * factorials(l - m) * ((2.0_dp * l) + 1) / (4.0_dp * PI)) &
                                  * (normsq_x**(-0.5_dp * l))

          GradSphericalYCartesian_all(l,m,:) = GradSphericalYCartesian_all(l,m,:) &
                                  - (l * x * SphericalYCartesian(l, m, x) / normsq_x)
        end do
        end do

    end function GradSphericalYCartesian_all

   subroutine cg_initialise(j,denom)

      integer, intent(in) :: j
      integer :: i_j1,i_m1,i_j2,i_m2,i_j,i_m
      integer, intent(in), optional :: denom

      integer :: my_denom

      if (cg_initialised .and. j > cg_j_max) then ! need to reinitialise
	 call cg_finalise()
	 cg_initialised = .false.
      endif
      if (cg_initialised) return

      my_denom = optional_default(1,denom)

      cg_j1_max = j
      cg_m1_max = j
      cg_j2_max = j
      cg_m2_max = j
      cg_j_max = j !(j1_max+j2_max)
      cg_m_max = j !(j1_max+j2_max)

      allocate( cg_array(0:cg_j1_max,-cg_m1_max:cg_m1_max,0:cg_j2_max,-cg_m2_max:cg_m2_max,&
      & 0:cg_j_max,-cg_j_max:cg_j_max) )

      cg_array = 0.0_dp

      do i_j1 = 0, cg_j1_max
      do i_m1 = -i_j1, i_j1, my_denom
      do i_j2 = 0, cg_j2_max
      do i_m2 = -i_j2, i_j2, my_denom
      do i_j = abs(i_j1-i_j2), min(cg_j_max,i_j1+i_j2)
      do i_m = -i_j, i_j, my_denom

         cg_array(i_j1,i_m1,i_j2,i_m2,i_j,i_m) = cg_calculate(i_j1,i_m1,i_j2,i_m2,i_j,i_m,denom)

      enddo
      enddo
      enddo
      enddo
      enddo
      enddo

      cg_initialised = .true.

   endsubroutine cg_initialise

   !#################################################################################
   !#
   !% Finalise global CG arrays
   !#
   !#################################################################################

   subroutine cg_finalise

      cg_j1_max = 0
      cg_m1_max = 0
      cg_j2_max = 0
      cg_m2_max = 0
      cg_j_max = 0
      cg_m_max = 0

      if(allocated(cg_array)) deallocate( cg_array )
      cg_initialised = .false.

   endsubroutine cg_finalise

   !#################################################################################
   !#
   !% Look up CG coefficient from CG array, previously calculated.
   !#
   !#################################################################################

   function cg_lookup(j1,m1,j2,m2,j,m,denom) result(cg)

     real(dp)            :: cg
     integer, intent(in) :: j1,m1,j2,m2,j,m
     integer, intent(in), optional :: denom

     cg=0.0_dp

     if ( .not. cg_check(j1,m1,j2,m2,j,m,denom) ) then
        return
     endif

     if( j1<=cg_j1_max .and. j2<=cg_j2_max .and. j<=cg_j_max .and. &
       abs(m1)<=cg_m1_max .and. abs(m2)<=cg_m2_max .and. abs(m) <= cg_m_max .and. cg_initialised ) then
         cg = cg_array(j1,m1,j2,m2,j,m)
     else
         cg = cg_calculate(j1,m1,j2,m2,j,m,denom)
     endif

   endfunction cg_lookup

   !#################################################################################
   !#
   !% Check if input variables for CG make sense.
   !% Source: http://mathworld.wolfram.com/Clebsch-GordanCoefficient.html \\
   !%
   !% $ j_1 + j_2 \ge j $ \\
   !% $ j_1 - j_2 \ge -j $ \\
   !% $ j_1 - j_2 \le j $ \\
   !% $ j_1 \ge m_1 \ge j_1 $ \\
   !% $ j_2 \ge m_2 \ge j_2 $ \\
   !% $ j \ge m \ge j $ \\
   !% $ m_1 + m_2 = m $ \\
   !#
   !#################################################################################

   function cg_check(j1,m1,j2,m2,j,m,denom)

      logical :: cg_check
      integer, intent(in) :: j1,m1,j2,m2,j,m
      integer, intent(in), optional :: denom

      integer :: my_denom

      my_denom = optional_default(1,denom)
      cg_check = (j1>=0) .and. (j2>=0) .and. (j>=0) .and. &
               (abs(m1)<=j1) .and. (abs(m2)<=j2) .and. (abs(m)<=j) &
               .and. (m1+m2==m) .and. (j1+j2 >= j) .and. (abs(j1-j2) <= j) &
               .and. (mod(j1+j2+j,my_denom)==0)

   endfunction cg_check

   !#################################################################################
   !#
   !% Calculate a Clebsch-Gordan coefficient $\left< j_1 m_1 j_2 m_2 | j m \right>$
   !% Source: http://mathworld.wolfram.com/Clebsch-GordanCoefficient.html \\
   !% $ \left< j_1 m_1 j_2 m_2 | j m \right> = (-1)^{m+j_1-j_2)
   !% \sqrt{2j+1} \left( \begin{array}{ccc}
   !% j_1 & j_2 & j \\
   !% m_1 & m_2 & -m \\
   !% \end{array} \right) $
   !% where the thing on the right-hand side is the Wigner 3J symbol.
   !#
   !#################################################################################

   function cg_calculate(j1,m1,j2,m2,j,m,denom) result(cg)

     real(dp)            :: cg
     integer, intent(in) :: j1,m1,j2,m2,j,m
     integer, intent(in), optional :: denom

     integer :: my_denom

     my_denom = optional_default(1,denom)

     cg=0.0_dp
     if ( .not. cg_check(j1,m1,j2,m2,j,m,denom) ) return

     cg = oscillate((m+j1-j2)/my_denom) * sqrt(2.0_dp*real(j,dp)/real(my_denom,dp)+1.0_dp) * &
     wigner3j(j1,m1,j2,m2,j,-m,denom)

   end function cg_calculate

   !#################################################################################
   !#
   !% Triangle coefficient
   !% Source: http://mathworld.wolfram.com/TriangleCoefficient.html
   !%
   !% $ \Delta(a,b,c) = \frac{ (a+b-c)! (a-b+c)! (-a+b+c)! }{ (a+b+c+1)! } $
   !#
   !#################################################################################

   function tc(a,b,c,denom)

      real(dp) :: tc
      integer, intent(in) :: a, b, c
      integer, intent(in), optional :: denom
      integer :: my_denom

      my_denom = optional_default(1,denom)

      tc = factorial((a+b-c)/my_denom) * factorial((a-b+c)/my_denom) * &
      factorial((-a+b+c)/my_denom) / factorial((a+b+c)/my_denom+1)

   endfunction tc

   !#################################################################################
   !#
   !% Wigner 3J symbol
   !% Source: http://mathworld.wolfram.com/Wigner3j-Symbol.html
   !%
   !% \[
   !% \left( \begin{array}{ccc}
   !% j_1 & j_2 & j \\
   !% m_1 & m_2 & m \\
   !% \end{array} \right) = (-1)^{j_1-j_2-m) \sqrt{ \Delta (j_1,j_2,j) }
   !% \sqrt{ (j_1+m_1)! (j_1-m_1)! (j_2+m_2)! (j_2-m_2)! (j+m)! (j-m)! }
   !% \sum_k \frac{ (-1)^k }{k! (j-j_2+k+m_1)! (j-j_1+k-m_2)! (j_1+j_2-j-k)!
   !% (j_1-k-m_1)! (j_2-k+m_2)! }
   !% \]
   !% the summation index k runs on all integers where none of the argument of
   !% factorials are negative
   !% $\Delta(a,b,c)$ is the triangle coefficient.
   !#
   !#################################################################################

   function wigner3j(j1,m1,j2,m2,j,m,denom)

       real(dp)            :: wigner3j
       integer, intent(in) :: j1,m1,j2,m2,j,m
       integer, intent(in), optional :: denom

       real(dp) :: pre_fac, triang_coeff, main_coeff, sum_coeff, sum_term
       integer  :: k, kmin, kmax, my_denom

       my_denom = optional_default(1,denom)

       pre_fac = oscillate((j1-j2-m)/my_denom)

       triang_coeff = sqrt( tc(j1,j2,j,denom) )

       main_coeff = sqrt( &
                  factorial((j1+m1)/my_denom) * factorial((j1-m1)/my_denom) * &
                  factorial((j2+m2)/my_denom) * factorial((j2-m2)/my_denom) * &
                  factorial((j+m)/my_denom) * factorial((j-m)/my_denom) )

       sum_coeff = 0.0_dp

       kmin = max( j2-j-m1, j1+m2-j, 0 ) / my_denom
       kmax = min( j1+j2-j, j1-m1, j2+m2) / my_denom

       do k = kmin, kmax

          sum_term = 1.0_dp / ( factorial(k) * factorial((j-j2+m1)/my_denom+k) * &
                   factorial((j-j1-m2)/my_denom+k) * factorial((j1+j2-j)/my_denom-k) * &
                   factorial((j1-m1)/my_denom-k) * factorial((j2+m2)/my_denom-k) )

          sum_term = oscillate(k) * sum_term

          sum_coeff = sum_coeff + sum_term

       enddo

       wigner3j = pre_fac * triang_coeff * main_coeff * sum_coeff

   endfunction wigner3j

end module angular_functions_module


	FUNCTION PS_SHOW  ( t850, td850, t500 )
C************************************************************************
C* PS_SHOW 								*
C*									*
C* This function computes the Showalter index:				*
C*									*
C*      SHOW = T500 - Tparcel						*
C*									*
C*           Tparcel = Temperature in Celsius at 500 mb of a parcel	*
C*                     which lies on the moist adiabat determined	*
C*                     by the sounding at 850 mb			*
C*									*
C* REAL PS_SHOW  ( T850, TD850, T500 )					*
C*                							*
C* Input parameters:                                                    *
C*	T850    	REAL		850 mb temperature in Celsius	*
C*	TD850		REAL		850 mb dewpoint in Celsius	*
C*	T500		REAL		500 mb temperature in Celsius	*
C*									*
C* Output parameters:							*
C*	PS_SHOW		REAL		Showalter index			*
C**									*
C* Log:									*
C* P. Kocin/GSFC	 1980	Original source called PR_SHOW		*
C* M. Goodman/RDS	 8/84	Renamed and cleaned prologue		*
C* M. desJardins/GSFC	 3/88	Documentation				*
C************************************************************************
        INCLUDE      'GEMPRM.PRM'
        INCLUDE      'ERMISS.FNC'
C----------------------------------------------------------------------------
	IF  ( ERMISS ( t850 ) .or. ERMISS ( td850 ) .or.
     +	      ERMISS ( t500 ) )  THEN
	    PS_SHOW = RMISSD
	  ELSE
	    p850 = 850.
C
C*	    Find equivalent potential temperture at the LCL using 850 mb
C*	    temperature and dewpoint.
C
	    thtlcl = PR_THTE ( p850, t850, td850 )
	    p500   = 500.
C
C*	    Find parcel temperature along pseudoadiabat at 500 mb.
C
	    guess = 0.
	    tp    = PR_TMST  ( thtlcl, p500, guess )
C
C*	    If parcel temp is no good, then set the index to missing.
C
	    IF  ( ERMISS ( tp ) )  THEN
		PS_SHOW = RMISSD
	      ELSE
C
C*	 	Else subtract the parcel temp from the temp at 500 mb.
C
		t500k   = pr_tmck ( t500 )
		PS_SHOW = t500k - tp
	    END IF
	END IF
C*
	RETURN
	END


PROGRAM PE2D_HFR
 USE NRTYPE
 USE MATLIB
 USE PARAM
 USE GROUND
 IMPLICIT NONE
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) "========== Parabolic Equation Package =========="
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "University of Bristol"
 WRITE(*,*) "Aerodynamics and Aeroacoustics Research Group"
 WRITE(*,*) ""
 WRITE(*,*) "Codor Khodr, July 2016"
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "PE2D_HFR"
 WRITE(*,*) "Dimension : 2D"
 WRITE(*,*) "Atmosphere : Homogeneous"
 WRITE(*,*) "Boundary : Flat"
 WRITE(*,*) "Impedance : Rigid"
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "Enter inputs L, f, zs, As"
 WRITE(*,*) ""
 READ *, L, F, ZS, ABL
 WRITE(*,*) ""
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 C0 = 343.0_DP
 LMBDA0 = C0/F
 K0 = 2*PI*F/C0
 DZ = LMBDA0/10
 DR = LMBDA0/10
 H = 100*LMBDA0
 HABL = 30*LMBDA0
 N = FLOOR(H/DZ)
 M = FLOOR(L/DR)
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "Size of the system : ", N
 WRITE(*,*) "Number of steps : ", M
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 NS = MAX(1,FLOOR(ZS/DZ))
 NABL = FLOOR(HABL/DZ)
 ALPHA = IM/(2.0_DP*K0*DZ**2)
 KU = 1
 KL = 1
 NDIAG = KU+KL+1
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Memory allocation
 ALLOCATE(K(N), DK2(N), ALT(N), PHI(N,M+1), T(N,N), D(N,N), M1(N,N), &
 M2(N,N), I(N,N), P(N,M), LP(N,M), LP2(N,M), LPG(M), LPG2(M), E(N,N), &
 MB2(NDIAG,N), MB1(NDIAG,N), WORK(N), RWORK(2*N), CWORK(2*N), TEMP(N,1), &
 MTEMP(2*KL+KU+1,N), IPIV(N), TEMP(N))
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 DO NZ = 1,N
  IF (NZ.GE.N-NABL) THEN
   K(NZ) = K0+ABL*IM*(NZ-N+NABL)**2/NABL**2
  ELSE
   K(NZ) = K0
  ENDIF
  DK2(NZ) = IM*(K(NZ)**2-K0**2)/(2*K0)
  ALT(NZ) = NZ*DZ
 END DO
 TAU1 = 4./(3.-2.*IM*K0*DZ)
 TAU2 = -1./(3.-2.*IM*K0*DZ)
 SIGMA1 = 4./3.
 SIGMA2 = -1./3.
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 A0 = 1.3717
 A2 = -0.3701
 B = 3.
 DO NZ = 1,N
  PHI(NZ,1) = SQRT(IM*K0)* &
              ((A0+A2*K0**2*(NZ*DZ-ZS)**2)*EXP(-K0**2*(NZ*DZ-ZS)**2/B) + &
              (A0+A2*K0**2*(NZ*DZ+ZS)**2)*EXP(-K0**2*(NZ*DZ+ZS)**2/B))
 END DO
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Initialization (Dense Matrices)
 !FDW = [1 -2 1]  !Finite Difference Weights
 !---------
 T(:,:) = 0._DP
 DO NZ = 2,N-1
  T(NZ,NZ-1) = T(NZ,NZ-1)+1.
  T(NZ,NZ) = T(NZ,NZ)-2.
  T(NZ,NZ+1) = T(NZ,NZ+1)+1.
 END DO
 T(1,1) = T(1,1)-2.+SIGMA1
 T(1,2) = T(1,2)+1.+SIGMA2
 T(N,N-1) = T(N,N-1)+1.+TAU2
 T(N,N) = T(N,N)-2.+TAU1
 E = DIAG(ALT)
 D = DIAG(DK2)
 I = EYE(N)
 !-----------------------------------------------------------
 !System - M1 and M2
 !---------
 BETA1 = 1./(2.*IM*K0)+DR/2.
 BETA2 = 1./(2.*IM*K0)-DR/2.
 M1 = I+ALPHA*BETA1*T+BETA1*D
 M2 = I+ALPHA*BETA2*T+BETA2*D
 !CALL DENSE2BAND(M1,N,KL,KU,MB1)
 MB2 = DENSE2BAND(M2,N,KL,KU)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Forward-marching procedure
 CALL CPU_TIME(TI)
 !-----------------------------------------------------------
 DO MX = 2,M+1
  WRITE(*, *) "Step :", MX-1, "out of", M
  TEMP(:,1) = MATMUL(M1,PHI(1:N,MX-1))
  !CALL ZGBMV('N',N,N,KL,KU,1.,MB1,KL+KU+1,PHI(1:N,MX-1),1,0.,TEMP(:,1),1)
  WRITE(*, *) ".... Right-hand side multiplied"
  !MTEMP = M2
  MTEMP(KL+1:2*KL+KU+1,:) = MB2
  !CALL ZGESV(N,1,MTEMP,N,IPIV,TEMP,N,INFO)
  CALL ZGBSV(N,KL,KU,1,MTEMP,2*KL+KU+1,IPIV,TEMP(:,1),N,INFO)
  !CALL ZGTSV(N,1,MTEMP(2*KL+KU+1,1:N-1),MTEMP(KL+KU+1,1:N),MTEMP(KL+1,2:N),TEMP(:,1),N,INFO)
  IF (INFO.NE.0) THEN
   WRITE(*,*) INFO
   STOP "ERROR : Matrix is singular"
  END IF
  WRITE(*, *) ".... System solved"
  PHI(1:N,MX) = TEMP(:,1)
  P(1:N,MX-1) = EXP(IM*K0*(MX-1)*Dr)*PHI(1:N,MX)*(1/SQRT((MX-1)*Dr))
 END DO
! !-----------------------------------------------------------
! IF (SP == 0) THEN
! !-----------------------------------------------------------
!  MAT = MATMUL(INV(M2),M1)
!  DO MX = 2,M+1
!   WRITE(*, *) "Step :", MX-1, "out of", M
!   PHI(1:N,MX) = MATMUL(MAT,PHI(1:N,mx-1))
!   P(1:N,MX-1) = EXP(im*K0*(MX-1)*Dr)*PHI(1:N,MX)*(1/SQRT((MX-1)*Dr))
!  END DO
! !-----------------------------------------------------------
! ELSEIF (SP == 1) THEN
! !-----------------------------------------------------------
!   MAT_SP = SPCONV(MAT) ! SLOW PROCEDURE !
!   NELT = MAT_SP%NELT
!   ALLOCATE(IMAT(NELT),JMAT(NELT))
!   IMAT = MAT_SP%ROW
!   JMAT = MAT_SP%COL
!   VALMAT = MAT_SP%VAL
!   DO MX = 2,M+1
!    WRITE(*, *) "Step :", mx-1, "out of", M
!    CALL DSMV(N,PHI(1:N,MX-1),PHI(1:N,MX),NELT,IMAT,JMAT,VALMAT,0)
!    P(1:N,mx-1) = EXP(im*K0*(MX-1)*Dr)*PHI(1:N,MX)*(1/SQRT((MX-1)*Dr))
!   END DO
! !-----------------------------------------------------------
! ELSE
! !-----------------------------------------------------------
!  ALLOCATE(SA1(N**3),SA2(N**3),IJA(N**3))
!  THRESH = 0
!  TOL = 1.0e-4_dp
!  CALL SPRSIN_DP(M1,THRESH,SP1)
!  CALL SPRSIN_DP(M2,THRESH,SP2)
!  DO MX = 2,M+1
!   WRITE(*, *) "Step :", mx-1, "out of", M
!   CALL SPRSAX_DP(SP1,PHI(1:N,MX-1),TEMP)
!   CALL LINBCG(SP2,TEMP,PHI(1:N,MX),1,TOL,10,ITER,ERR)
!   P(1:N,mx-1) = EXP(im*K0*(MX-1)*Dr)*PHI(1:N,MX)*(1/SQRT((MX-1)*Dr))
!  END DO
! !-----------------------------------------------------------
! END IF
! !-----------------------------------------------------------
 CALL CPU_TIME(TF)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Transmission loss conversion
 P0 = P(NS,1)
 DO MX = 1,M
  DO NZ = 1,N
   LP(NZ,MX) = 20.*LOG10(ABS(P(NZ,MX)/P0))
  END DO
 END DO
 LPG = LP(1,1:M)
 LP2 = LP/SQRT(2.)
 LPG2 = LP2(1,1:M)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Output
 OPEN(UNIT=10,FILE="results/PE2D_HFR_LPg.dat")
 OPEN(UNIT=20,FILE="results/PE2D_HFR_LP.dat")
 OPEN(UNIT=30,FILE="results/PE2D_HFR_P.dat")
 DO NZ = 1,N
  WRITE(20, 102) LP(NZ,1:M)
  WRITE(30, 101) P(NZ,1:M)
 END DO
 DO MX = 1,M
  WRITE(10, 100) MX*Dr, LPG(MX), LPG2(MX)
 END DO
 100 FORMAT(3(3X,F12.3))
 101 FORMAT(3X,F12.3,SP,F12.3,SS,"i")
 102 FORMAT(100000(3X,F12.3))
 PRINT *, "Main CPU time (s) :", TF-TI
 PRINT *, "Source pressure P0 (dB) :", 20*LOG10(ABS(P0))
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Checking Matrix conditioning
 NORM = ZLANGE('I',N,N,M1,N,WORK)
 WRITE(*,*) "||M1|| = ", NORM
 CALL ZGECON('I',N,M1,N,NORM,RCOND,CWORK,RWORK,INFO)
 WRITE(*,*) "K(M1) = ", RCOND, "COND(M1) = ", 1./RCOND
 WRITE(*,*)
 NORM = ZLANGE('I',N,N,M2,N,WORK)
 WRITE(*,*) "||M2|| = ", NORM
 CALL ZGECON('I',N,M2,N,NORM,RCOND,CWORK,RWORK,INFO)
 WRITE(*,*) "K(M2) = ", RCOND, "COND(M2) = ", 1./RCOND
 WRITE(*,*)
 NORM = ZLANGB('I',N,KL,KU,MB2,KL+KU+1,WORK)
 WRITE(*,*) "||M2|| = ", NORM
 CALL ZGBCON('I',N,KL,KU,MTEMP,2*KL+KU+1,IPIV,NORM,RCOND,CWORK,RWORK,INFO)
 WRITE(*,*) "K(M2) = ", RCOND, "COND(M2) = ", 1./RCOND
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Plotting of results
 CALL SYSTEM('gnuplot -p plot_flat.plt')
 !----------------------------------------------------------
END PROGRAM PE2D_HFR
!-----------------------------------------------------------
!-------------      EXTERNAL PROCEDURES      ---------------
!-----------------------------------------------------------


C     LAST UPDATE 16/03/89
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE LINFIT (X,Y,SIGMAY,NPTS,MODE,A,SIGMAA,B,SIGMAB,R)
      IMPLICIT NONE
C
C  PURPOSE: LEAST SQUARES FIT TO A STRAIGHT LINE.
C
      REAL X(1),Y(1),SIGMAY(1),A,SIGMAA,B,SIGMAB,R
      INTEGER NPTS,MODE

C X      : ABSCISSA DATA
C Y      : ORDINATE DATA
C SIGMAY : ARRAY OF STANDARD DEVIATIONS FOR Y VALUES
C NPTS   : NUMBER OF PAIRS OF DATA POINTS
C MODE   : DETERMINES THE METHOD OF WEIGHTING  VALUES
C               +1 (INSTRUMENTAL)  WT(I)=1./SIGMAY(I)**2
C                0 (NO WEIGHTING)  WT(I)=1.
C               -1 (STATISTICAL)  WT(I)=1./X(I)
C A      : Y INTERCEPT OF STRAIGHT LINE
C SIGMAA : STANDARD DEVIATION OF A
C B      : SLOPE OF FITTED LINE
C SIGMAB : STANDARD DEVIATION OF B
C R      : LINEAR CORRELATIION COEFFICIENT
C
C CALLS   0:
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C LOCAL VARIABLES:
C
      DOUBLE PRECISION WEIGHT
      DOUBLE PRECISION SUM,SUMX,SUMY,SUMX2,SUMXY,SUMY2,DELTA,VARNCE
      REAL    XI,YI,FREE
      INTEGER I
C
C WEIGHT : WEIGHTING FACTORS
C SUM    : ACCUMULATED SUM OF WEIGHTS
C SUMX   : ACCUMULATED SUM OF WEIGHTED X DATA
C SUMY   : ACCUMULATED SUM OF WEIGHTED Y DATA
C SUMX2  : ACCUMULATED SUM OF WEIGHTED Y*Y DATA
C SUMXY  : ACCUMULATED SUM OF WEIGHTED X*Y DATA
C SUMY2  : ACCUMULATED SUM OF WEIGHTED Y*Y DATA
C DELTA  : WEIGHTING FOR COEFFICIENTS
C VARNCE : VARIANCE
C
C-----------------------------------------------------------------------
C
C========ACCUMULATING SUMS
C
      SUM=0
      SUMX=0
      SUMY=0
      SUMX2=0
      SUMXY=0
      SUMY2=0
C
      DO 70 I=1,NPTS
         XI = X(I)
         YI = Y(I)
         IF(MODE) 10,40,50
10       IF (YI) 30,40,20
20          WEIGHT=1./(YI)
            GOTO 60
30          WEIGHT=1./(-YI)
            GOTO 60
40          WEIGHT=1.
            GOTO 60
50          WEIGHT=1./SIGMAY(I)**2
C
60       SUM = SUM + WEIGHT
         SUMX = SUMX + WEIGHT*XI
         SUMY = SUMY + WEIGHT*YI
         SUMX2 = SUMX2 + WEIGHT*XI*XI
         SUMXY = SUMXY + WEIGHT*XI*YI
         SUMY2 = SUMY2 + WEIGHT*YI*YI
70    CONTINUE
C
C========CALCULATING COEFFICIENTS & STANDARD DEVIATIONS
C
      DELTA = SUM*SUMX2 - SUMX*SUMX
      A     = (SUMX2*SUMY - SUMX*SUMXY)/DELTA
      B     = (SUMXY*SUM - SUMX*SUMY)/DELTA
      IF (MODE) 80,90,80
80       VARNCE=1.0
         GOTO 100
90       FREE = REAL(NPTS-2)
         VARNCE = (SUMY2 + A*A*SUM + B*B*SUMX2
     1            -2.0*(A*SUMY + B*SUMXY - A*B*SUMX))/FREE
100   SIGMAA = DSQRT(VARNCE*SUMX2/DELTA)
      SIGMAB = DSQRT(VARNCE*SUM/DELTA)
      R = (SUM*SUMXY-SUMX*SUMY)/DSQRT(DELTA*(SUM*SUMY2-SUMY*SUMY))
      RETURN
C
      END


SUBROUTINE evolve(grid, scratch, D, dt, N, M)
    !f2py threadsafe
    !f2py intent(in) grid
    !f2py intent(inplace) scratch
    !f2py intent(in) D
    !f2py intent(in) dt
    !f2py intent(hide) N
    !f2py intent(hide) M
    INTEGER :: N, M
    DOUBLE PRECISION, DIMENSION(N,M) :: grid, scratch
    DOUBLE PRECISION, DIMENSION(N-2, M-2) :: laplacian
    DOUBLE PRECISION :: D, dt

    laplacian = grid(3:N, 2:M-1) + grid(1:N-2, 2:M-1) + &
                grid(2:N-1, 3:M) + grid(2:N-1, 1:M-2) - 4 * grid(2:N-1, 2:M-1)
    scratch(2:N-1, 2:M-1) = grid(2:N-1, 2:M-1) + D * dt * laplacian
END SUBROUTINE evolve


subroutine qinit(meqn,mbc,mx,xlower,dx,q,maux,aux)

    ! Set initial conditions for the q array.
    ! This default version prints an error message since it should
    ! not be used directly.  Copy this to an application directory and
    ! loop over all grid cells to set values of q(1:meqn, 1:mx).

    implicit none

    integer, intent(in) :: meqn,mbc,mx,maux
    real(kind=8), intent(in) :: xlower,dx
    real(kind=8), intent(in) :: aux(maux,1-mbc:mx+mbc)
    real(kind=8), intent(inout) :: q(meqn,1-mbc:mx+mbc)

    integer :: i
    real(kind=8) :: r ,pi, xcell, center, mu1,mu2,mu3,mu4

    common /cparam/ mu1,mu2,mu3,mu4

    pi = 4.0d0*datan(1.0d0)
    r = 0.2d0
    center = 0.25d0+ 1.0d-8

    do i=1,mx
      xcell = xlower + (i-0.5d0)*dx
      if ((xcell .ge. center-r) .and. (xcell .le. center+r)) then
        q(1,i) = 0.5d0 + 0.5d0*dcos((xcell-center)/r*pi)
      elseif (xcell .le. center-r) then
        q(1,i) = 0.0d0
      else
        q(1,i) = 0.0d0
      endif
    enddo

end subroutine qinit


C++---------------------------------------------------------
C Program to multiply an image with a mask
C
C JLP
C Version of 20-04-2008
C---------------------------------------------------------
	PROGRAM MASK
	PARAMETER (IDIM=512)
	REAL*4 IMAGE2(IDIM,IDIM),IMAGE1(IDIM,IDIM),MASK2(IDIM,IDIM)
        REAL*4 XLEVEL,RADIUS,RAD2,RR2,EQUIV_RADIUS
        INTEGER*4 IXC,IYC,NPOINTS,NX,NY,ICHOICE
	CHARACTER ANS*1,NAME*40,COMMENTS*80

10	FORMAT(A)

	CALL JLP_BEGIN
C Inquire the format of the files :
	CALL JLP_INQUIFMT

	PRINT 85
85	FORMAT(' MENU :',/,
     1	' 1. Creation of a circular mask ',/,
     1	' 2. Creation of a mask with isophotes',/,
     1	' 3. Multiplying with a mask (file)',/,
     1	' 4. Multiplying with a circular mask',/,
     1	' 10. Exit',/,
     1	' Enter your choice : ',$)
	READ(5,*) ICHOICE
        IF(ICHOICE.GT.4) THEN
          CALL JLP_END
          STOP
        ENDIF

C------------------------------------------------------------------
C Circular mask:
C---------------
	IF(ICHOICE.EQ.1)THEN
200	PRINT *,' SIZE OF THE OUTPUT FILE : NX,NY ? (MAX=',IDIM,'x',IDIM,')'
	READ(5,*) NX,NY
        IF(NX.GT.IDIM.OR.NY.GT.IDIM) GOTO 200

	PRINT *,' Warning: range of coordinates from 1 to NX or NY...'
	PRINT *,' CENTRE IXC,IYC (0,0 for centered circle) AND RADIUS: ? '
	READ(5,*) IXC,IYC,RADIUS
        IF(IXC.EQ.0.AND.IYC.EQ.0)THEN
          IXC = NX/2 + 1
          IYC = NY/2 + 1
        ENDIF
	RAD2=RADIUS*RADIUS

C Erasing output file:
        DO IY=1,NY
          DO IX=1,NX
           IMAGE2(IX,IY)=0.
          ENDDO
        ENDDO

C Generating the array IMAGE2 :
        DO IY=1,NY
        DO IX=1,NX
	RR2=(IX-IXC)*(IX-IXC)+(IY-IYC)*(IY-IYC)
	   IF(RR2.LE.RAD2)THEN
	     IMAGE2(IX,IY)=1.
	   ENDIF
	END DO
	END DO
        WRITE(COMMENTS,11) IXC,IYC,RADIUS
11      FORMAT('Circular mask: IXC=',I4,' IYC=',I4,' Radius=',G9.2)

C------------------------------------------------------------------
C Isophotes:
C-----------
	ELSEIF(ICHOICE.EQ.2)THEN

C Input of the file:
        WRITE(6,*) 'Input file: '
        READ(5,10) NAME
	CALL JLP_READIMAG(IMAGE1,NX,NY,IDIM,NAME,COMMENTS)

C Input of the parameters :
	PRINT *,' Isophote level ?'
	READ(5,*) XLEVEL

C Scanning the image :
        NPOINTS=0
	DO IY=1,NY
	 DO IX=1,NX
          IF(IMAGE1(IX,IY).GE.XLEVEL)THEN
	    IMAGE2(IX,IY)=1.
            NPOINTS=NPOINTS+1
          ENDIF
	 END DO
	END DO

        EQUIV_RADIUS=SQRT(FLOAT(NPOINTS)/3.14159)
        WRITE(6,22) NPOINTS,EQUIV_RADIUS
22      FORMAT('NPOINTS=',I5,' EQUIV_RADIUS=',G9.2)
        WRITE(COMMENTS,21) XLEVEL,NAME
21      FORMAT('Isophotal mask: Level=',G9.2,' from:',A)

C------------------------------------------------------------------
C Multiplication with a mask:
C----------------------------
	ELSEIF(ICHOICE.EQ.3)THEN

C Entering the mask :
        WRITE(6,*) 'Input mask: '
        READ(5,10) NAME
	CALL JLP_READIMAG(MASK2,NX,NY,IDIM,NAME,COMMENTS)

C Input of the file:
        WRITE(6,*) 'Input file: '
        READ(5,10) NAME
	CALL JLP_READIMAG(IMAGE1,NX,NY,IDIM,NAME,COMMENTS)

C Masking the image :
	DO IY=1,NY
	 DO IX=1,NX
	  IMAGE2(IX,IY)=IMAGE1(IX,IY)*MASK2(IX,IY)
	 END DO
	END DO

C------------------------------------------------------------------
C Multiplication with a circular mask:
C-------------------------------------
	ELSEIF(ICHOICE.EQ.4)THEN

C Input of the parameters :
	PRINT *,' Center : IX,IY and radius?'
	READ(5,*) IXC,IYC,RADIUS

C Input of the file:
        WRITE(6,*) 'Input file: '
        READ(5,10) NAME
	CALL JLP_READIMAG(IMAGE1,NX,NY,IDIM,NAME,COMMENTS)

C Masking the image :
	CALL MASK_CIRC(IMAGE1,IMAGE2,NX,NY,IDIM,IXC,IYC,RADIUS)

	COMMENTS=' '
        WRITE(COMMENTS,41) NAME,IXC,IYC,RADIUS
41      FORMAT(A,' masked: IXC=',I4,' IYC=',I4,' Radius=',G9.2)
C------------------------------------------------------------------
	ENDIF

C------------------------------------------------------------------
C Output :
        WRITE(6,*) 'Output file: '
        READ(5,10) NAME
	CALL JLP_WRITEIMAG(IMAGE2,NX,NY,IDIM,NAME,COMMENTS)

	CALL JLP_END
	STOP
	END
C---------------------------------------------------------
C Subroutine to multiply with a circular mask
C
C Input :
C IMAGE1(NX,NY)
C IXC,IYC : centre coordinates
C RADIUS : radius
C
C Output :
C IMAGE2(NX,NY)
C
C---------------------------------------------------------
	SUBROUTINE MASK_CIRC(IMAGE1,IMAGE2,NX,NY,IDIM,IXC,IYC,RADIUS)
	REAL*4 IMAGE1(IDIM,*),IMAGE2(IDIM,*)
        INTEGER*4 IX,IY,NX,NY,IDIM,IXC,IYC
        REAL*4 RR2,RADIUS

	RAD2=RADIUS*RADIUS

C Main loop :
	DO IY=1,NY
	DO IX=1,NX
	  RR2=(IX-IXC)*(IX-IXC)+(IY-IYC)*(IY-IYC)
	  IF(RR2.GT.RAD2)THEN
	    IMAGE2(IX,IY)=0.
          ELSE
	    IMAGE2(IX,IY)=IMAGE1(IX,IY)
	  ENDIF
	END DO
	END DO

	RETURN
	END


program calc_integer
  implicit none   !forces the programmer to declare all variables
  integer :: w,l
  integer :: prmtr, area, diag1, diag2

  w = 3                    !Define a
  l = 4                    !Define b
  prmtr = 2*(w + l)        !Calculate the perimeter of rectangle
  area  = w*l              !Calculate the area of rectangle

  !> Should give error on compilation
  diag1 = sqrt(w**2+l**2) !Calculate diagonal
  diag2 =(w**2+l**2)**0.5  !Calculate diagonal

  print*, 'Perimeter = ',prmtr
  print*, 'Area = ' ,area
  print*, 'diag1 = ',diag1
  print*, 'diag2 = ',diag2

end program calc_integer


! **********************************************
!  Last updated: December 10, 2012
! **********************************************
!
! This subroutine computes the roots of a real polynomial of degree N
! in any recursively defined polynomial basis. The general
! algorithm is outlined in:
!
! Fast Computation of Eigenvalues of Companion, Comrade and Related Matrices, BIT Numerical Mathematics 2012
!
! **************************************************************
!
! Input variables:
!
! BANDSWITCH   0 indicates no COEFFS are input, 1 indicates COEFFS are given
!
! N            degree of polynomial
!
! K            maximum length of the recursion
!
! POLY         array of dimension N+1 containing the coefficients
!              of the polynomial in terms of the basis elements
!
! COEFFS       array of dimension (N x K) containing the recursion
!	       coefficients of the basis elements, ignored if BANDSWITCH = 0
!
! Output variables:
!
! RROOTS       contains the real part of the computed roots, dimension N
!
! IROOTS       contains the imaginary part of the computed roots, dimension N
!
! ITERATIONS   integer array storing the number of iterations per root calculation
!
! FLAG         reports the position of any instance where the algorithm
!              tried to divide by 0
!
! ***************************************************************

subroutine DAVW2(BANDSWITCH,N,K,POLY,COEFFS,RROOTS,IROOTS,ITERATIONS,FLAG)

	implicit none

	integer, intent(in) :: BANDSWITCH,N,K
	integer, intent(inout) :: ITERATIONS(N),FLAG
	double precision, intent(in) :: POLY(N+1),COEFFS(N,K)
	double precision, intent(inout) :: RROOTS(N),IROOTS(N)

	FLAG = 0

	if(BANDSWITCH == 0)then

		call DLR(N,POLY,RROOTS,IROOTS,ITERATIONS,FLAG)

	else if(BANDSWITCH == 1)then

		call DBLR(N,K,POLY,COEFFS,RROOTS,IROOTS,ITERATIONS,FLAG,0,0)

	else

		write(*,*) "Not a valid argument for BANDSWITCH"
		write(*,*) ""
		return
	end if

end subroutine

! **************************************************************
!
! This subroutine calculates the roots using the companion matrix
!
! **************************************************************

subroutine DLR(N,POLY,RROOTS,IROOTS,ITERATIONS,FLAG)

  implicit none

  integer, intent(in) :: N
  double precision, intent(in) :: poly(N)
  double precision, intent(out) :: rroots(N),iroots(N)
  integer, intent(out) :: iterations(N),flag
  integer :: stop_index,start_index,zero_index,ii,jj,kk,mm,it_count,it_max,info
  double precision :: tolerance=1d-16,zero_point,diagonals,diag1,diag2,norm
  double precision :: trace,detm
  double precision :: A(2,2),L1,L2,L3,K,G(3),Blocks(2,2,N)

! Initialize and normalize blocks
  if(dabs(poly(1)) == 0)then
	write(*,*) "Polynomial is of degree less than N!"
	return
  end if

  do ii=2,N
	Blocks(1,1,ii) = -poly(ii)/poly(1)
	Blocks(1,2,ii) = 1d0
	Blocks(2,1,ii) = 1d0
	Blocks(2,2,ii) = 0d0
  end do

  Blocks(1,2,N) = -poly(N+1)/poly(1)

  Blocks(1,1,1) = 0d0
  Blocks(1,2,1) = 0d0
  Blocks(2,1,1) = 0d0
  Blocks(2,2,1) = 1d0

! Main loop

  stop_index = N
  start_index = 2
  zero_index = 1
  it_max = 20*N
  it_count = 0
  flag = 0

  do mm=1,it_max

	! Zero check
	do ii=1,stop_index
		zero_point = dabs(Blocks(2,1,stop_index+1-ii))

		if(ii>1)then
			diag2 = dabs(Blocks(1,1,stop_index+2-ii)*Blocks(2,2,stop_index+1-ii))
		else
			diag2 = dabs(Blocks(2,2,stop_index+1-ii))
		end if

		if(ii<stop_index)then
			diag1 = dabs(Blocks(1,1,stop_index+1-ii)*Blocks(2,2,stop_index-ii))
		else
			diag1 = dabs(Blocks(1,1,stop_index+1-ii))
		end if

		diag1 = max(dabs(Blocks(2,1,stop_index-ii)),diag1)

		diag2 = max(dabs(Blocks(2,1,stop_index+2-ii)),diag2)

		diagonals = diag1 + diag2

		if(zero_point < tolerance*diagonals)then
			zero_index = stop_index+1-ii
			Blocks(2,1,zero_index) = 0d0

			! Deflate down if not at bottom
			if(zero_index<stop_index)then
				Blocks(1,1,zero_index+1) = Blocks(1,1,zero_index+1)*Blocks(2,2,zero_index)
				Blocks(1,2,zero_index+1) = Blocks(1,2,zero_index+1)*Blocks(2,2,zero_index)
				Blocks(2,2,zero_index) = 1d0
				Blocks(2,1,zero_index) = 0d0
				start_index = zero_index+1
			end if

			exit

		end if

	end do

	! zero at bottom
	if(zero_index==stop_index)then
		rroots(zero_index) = Blocks(2,2,zero_index)
		iroots(zero_index) = 0d0

		iterations(N-zero_index+1) = it_count
		it_count = 0

		if(stop_index<=1)then
			exit
		end if

		! deflate up
		Blocks(1,2,zero_index-1) = Blocks(1,2,zero_index-1)*Blocks(1,1,zero_index)
		Blocks(2,2,zero_index-1) = Blocks(2,2,zero_index-1)*Blocks(1,1,zero_index)
		Blocks(1,1,zero_index) = 1d0
		Blocks(2,1,zero_index) = 0d0

		stop_index = stop_index-1

	! 2x2 case
	else if(stop_index==start_index)then

		! calculate eigenvalues using modified quadratic
		trace = Blocks(1,1,stop_index) + Blocks(2,2,stop_index)
		detm = Blocks(1,1,stop_index)*Blocks(2,2,stop_index) - Blocks(1,2,stop_index)*Blocks(2,1,stop_index)

		if(dabs(trace)**2 < 4d0*detm)then
			rroots(stop_index) = trace/2d0
			iroots(stop_index) = dsqrt(4d0*detm - dabs(trace)**2)/2d0
			rroots(stop_index-1) = trace/2d0
			iroots(stop_index-1) = -dsqrt(4d0*detm - dabs(trace)**2)/2d0
		else
			rroots(stop_index) = (trace + dsqrt(dabs(trace)**2 - 4d0*detm))/2d0
			iroots(stop_index) = 0d0
			rroots(stop_index-1) = (trace - dsqrt(dabs(trace)**2 - 4d0*detm))/2d0
			iroots(stop_index-1) = 0d0
		end if

		iterations(N-stop_index+1) = it_count
		iterations(N-stop_index+2) = 0
		it_count = 0

		stop_index = stop_index-2

		! Breakout when done
		if(stop_index==0)then
			exit
		end if

		! Deflate up
		Blocks(1,2,stop_index) = Blocks(1,2,stop_index)*Blocks(1,1,stop_index+1)
		Blocks(2,2,stop_index) = Blocks(2,2,stop_index)*Blocks(1,1,stop_index+1)

		Blocks(1,1,stop_index+1) = 1d0

	! more than one block
	else
		it_count = it_count + 1

		! Build G
		if(mm == 0)then
			call dnormalpoly(2,G(1:2))
			trace = G(1) + G(2)
			detm = G(1)*G(2)
		else if(mod(it_count,15) == 0)then
			call dnormalpoly(2,G(1:2))
			G(2) = G(1)*G(1) + G(2)*G(2)
			G(2) = dsqrt(G(2))
			trace = 2d0*G(1)/G(2)
			detm = 1d0
			write(*,*) "Exceptional shift in DLR!"
		else
			trace = Blocks(2,2,stop_index-1)*Blocks(1,1,stop_index) + Blocks(2,2,stop_index)
			detm = Blocks(1,1,stop_index)*Blocks(2,2,stop_index) - Blocks(1,2,stop_index)*Blocks(2,1,stop_index)
			detm = Blocks(2,2,stop_index-1)*detm
		end if

		G(1) = Blocks(1,1,start_index)*Blocks(1,1,start_index) - trace*Blocks(1,1,start_index) + detm
		G(1) = G(1) + Blocks(1,2,start_index)*Blocks(2,1,start_index)*Blocks(1,1,start_index+1)
		G(2) = Blocks(1,1,start_index) + Blocks(2,2,start_index)*Blocks(1,1,start_index+1) - trace
		G(2) = Blocks(2,1,start_index)*G(2)
		G(3) = Blocks(2,1,start_index)*Blocks(2,1,start_index+1)

		! Build L3 L2 and L1
		L2 = G(3)/G(2);
		L3 = G(2)/G(1);

		! Build bulge
		A = Blocks(:,:,start_index)
		Blocks(2,:,start_index) = Blocks(2,:,start_index) - L3*Blocks(1,:,start_index)

		L1 = -L2*A(2,1)/Blocks(2,1,start_index)
		K = -L2*A(2,2) - L1*Blocks(2,2,start_index)

		Blocks(2,:,start_index+1) = Blocks(2,:,start_index+1) + K*Blocks(1,:,start_index+1)

		! Bulgechase
		do kk=(start_index+1),(stop_index)

			! Exit if at bottom
			if(kk==stop_index)then

				Blocks(:,1,kk) = Blocks(:,1,kk) + L2*Blocks(:,2,kk)

				call DGATO(Blocks(:,:,kk-1),Blocks(:,:,kk),L3,flag)

				Blocks(:,1,kk) = Blocks(:,1,kk) + L1*Blocks(:,2,kk)
				Blocks(:,1,kk) = Blocks(:,1,kk) + L3*Blocks(:,2,kk)

				exit
			end if

			call DGATO(Blocks(:,:,kk),Blocks(:,:,kk+1),L2,flag)
			call DGATO(Blocks(:,:,kk-1),Blocks(:,:,kk),L3,flag)

			call DGLTO(L1,L2,L3,flag)

		end do

	end if

  end do

  ! set flag for maxing out loop
  if(mm == it_max)then
  	flag = 1
  end if

end subroutine

! **************************************************************
!
! This subroutine calculates the roots using any congenial matrix
!
! **************************************************************

subroutine DBLR(N,K,POLY,COEFFS,RROOTS,IROOTS,ITERATIONS,FLAG,INIT,CHASE)

	implicit none

	integer, intent(in) :: N,K,INIT,CHASE
	double precision, intent(in) :: POLY(N+1),COEFFS(N,K)
	double precision, intent(inout) :: RROOTS(N),IROOTS(N)
	integer, intent(out) :: ITERATIONS(N),flag

	integer :: stop_index,start_index,zero_index,ii,jj,hh,mm,it_count=0,it_max
	integer :: length,switch=0
	double precision :: tolerance=1d-16,zero_point,diagonals,diag1,diag2
	double precision :: L1,L2,L3,W(2,2),A(3,2),M,bulge,trace,detm,G(3)
	double precision, allocatable :: spike(:),Blocks(:,:,:),Bands(:,:)

! Initialize Bands and Blocks

	allocate(spike(N),Blocks(2,2,N),Bands(N,K))

	if(dabs(poly(1)) == 0 .OR. dabs(Coeffs(1,1)) == 0)then
		write(*,*) "Polynomial is of degree less than N!"
		flag = 1
		return
	end if

	spike = -Poly(2:(N+1))/Poly(1)*Coeffs(1,1)
	spike(1:(K-1)) = spike(1:(K-1)) + Coeffs(1,2:K)

	Bands = 0d0
	Bands(1:(N-1),1:K) = Coeffs(2:N,1:K)

	Blocks(:,:,1) = 0d0
	Blocks(2,2,1) = 1d0

	do ii=1,(N-1)
		if(abs(Bands(ii,1)) == 0)then
			write(*,*) "Matrix is not properly upper-hessenberg!"
			flag = 2
			return
		end if

		L1 = spike(ii)/Bands(ii,1)

		length = min(N+1-ii,K)
		spike(ii:(ii+length-1)) = spike(ii:(ii+length-1)) - L1*Bands(ii,1:length)

		Blocks(1,1,ii+1) = L1
		Blocks(1,2,ii+1) = 1d0
		Blocks(2,1,ii+1) = 1d0
		Blocks(2,2,ii+1) = 0d0
	end do

	Bands(N,1) = spike(N)

! Main loop

  stop_index = N
  start_index = 2
  zero_index = 1
  it_max = 20*N
  it_count = 0
  flag = 0

  do mm=1,it_max

	! Zero check
	do ii=1,stop_index
		zero_point = dabs(Blocks(2,1,stop_index+1-ii))

		if(ii>1)then
			diag2 = dabs(Blocks(1,1,stop_index+2-ii)*Blocks(2,2,stop_index+1-ii)*Bands(stop_index+1-ii,1))
		else
			diag2 = dabs(Blocks(2,2,stop_index+1-ii)*Bands(stop_index+1-ii,1))
		end if

		if(ii<stop_index)then
			diag1 = dabs(Blocks(1,1,stop_index+1-ii)*Blocks(2,2,stop_index-ii)*Bands(stop_index-ii,1))
		else
			diag1 = dabs(Blocks(1,1,stop_index+1-ii)*Bands(stop_index-ii,1))
		end if

		diagonals = diag1 + diag2

		if(zero_point < tolerance*diagonals)then
			zero_index = stop_index+1-ii
			Blocks(2,1,zero_index) = 0d0

			! Deflate down if not at bottom
			if(zero_index<stop_index)then
				Blocks(1,1,zero_index+1) = Blocks(1,1,zero_index+1)*Blocks(2,2,zero_index)
				Blocks(1,2,zero_index+1) = Blocks(1,2,zero_index+1)*Blocks(2,2,zero_index)
				Blocks(1,2,zero_index) = Blocks(1,2,zero_index)/Blocks(2,2,zero_index)
				Blocks(2,2,zero_index) = 1d0
				start_index = zero_index+1
			end if

			exit

		end if
	end do

	! zero at bottom
	if(zero_index==stop_index)then
		rroots(zero_index) = Blocks(2,2,zero_index)*Bands(zero_index,1)
		iroots(zero_index) = 0d0

		iterations(N-zero_index+1) = it_count
		it_count = 0

		if(stop_index<=1)then
			exit
		end if

		! deflate up
		Blocks(:,2,zero_index-1) = Blocks(1,1,zero_index)*Blocks(:,2,zero_index-1)
		Blocks(1,1,zero_index) = 1d0

		stop_index = stop_index-1

	! 2x2 case
	else if(stop_index==start_index)then
		! calculate eigenvalues using modified quadratic
		if(K == 1)then
		W(1,1) = Blocks(1,1,stop_index)*Bands(stop_index-1,1)
		W(1,2) = Blocks(1,2,stop_index)*Bands(stop_index,1)
		W(2,1) = Blocks(2,1,stop_index)*Bands(stop_index-1,1)
		W(2,2) = Blocks(2,2,stop_index)*Bands(stop_index,1)
		else
		W(1,1) = Blocks(1,1,stop_index)*Bands(stop_index-1,1)
		W(1,2) = Blocks(1,1,stop_index)*Bands(stop_index-1,2) + Blocks(1,2,stop_index)*Bands(stop_index,1)
		W(2,1) = Blocks(2,1,stop_index)*Bands(stop_index-1,1)
		W(2,2) = Blocks(2,1,stop_index)*Bands(stop_index-1,2) + Blocks(2,2,stop_index)*Bands(stop_index,1)
		end if

		trace = W(1,1) + W(2,2)
		detm = W(1,1)*W(2,2) - W(1,2)*W(2,1)

		if(dabs(trace)**2 < 4d0*detm)then
			rroots(stop_index) = trace/2d0
			iroots(stop_index) = dsqrt(4d0*detm - dabs(trace)**2)/2d0
			rroots(stop_index-1) = trace/2d0
			iroots(stop_index-1) = -dsqrt(4d0*detm - dabs(trace)**2)/2d0
		else
			rroots(stop_index) = (trace + dsqrt(dabs(trace)**2 - 4d0*detm))/2d0
			iroots(stop_index) = 0d0
			rroots(stop_index-1) = (trace - dsqrt(dabs(trace)**2 - 4d0*detm))/2d0
			iroots(stop_index-1) = 0d0
		end if

		iterations(N-stop_index+1) = it_count
		iterations(N-stop_index+2) = 0
		it_count = 0

		stop_index = stop_index-2

		! Breakout when done
		if(stop_index==0)then
			exit
		end if

		! Deflate up
		Blocks(1,2,stop_index) = Blocks(1,2,stop_index)*Blocks(1,1,stop_index+1)
		Blocks(2,2,stop_index) = Blocks(2,2,stop_index)*Blocks(1,1,stop_index+1)

		Blocks(1,1,stop_index+1) = 1d0

	! more than one block
	else
		it_count = it_count + 1

		! shift calc
		if(K == 1)then
		W(1,1) = Blocks(1,1,stop_index)*Bands(stop_index-1,1)*Blocks(2,2,stop_index-1)
		W(1,2) = Blocks(1,2,stop_index)*Bands(stop_index,1)
		W(1,2) = W(1,2)*Blocks(2,2,stop_index-1)
		W(2,1) = Blocks(2,1,stop_index)*Bands(stop_index-1,1)
		W(2,2) = Blocks(2,2,stop_index)*Bands(stop_index,1)
		else
		W(1,1) = Blocks(1,1,stop_index)*Bands(stop_index-1,1)*Blocks(2,2,stop_index-1)
		W(1,2) = Blocks(1,1,stop_index)*Bands(stop_index-1,2) + Blocks(1,2,stop_index)*Bands(stop_index,1)
		W(1,2) = W(1,2)*Blocks(2,2,stop_index-1)
		W(2,1) = Blocks(2,1,stop_index)*Bands(stop_index-1,1)
		W(2,2) = Blocks(2,1,stop_index)*Bands(stop_index-1,2) + Blocks(2,2,stop_index)*Bands(stop_index,1)
		end if

		if(mm == 0)then
			trace = 0d0
			detm = -1d0
		else if(mod(it_count,15) == 0)then
			call dnormalpoly(2,G(1:2))
			G(2) = G(1)*G(1) + G(2)*G(2)
			G(2) = dsqrt(G(2))
			trace = 2d0*G(1)/G(2)
			detm = 1d0
			write(*,*) "Exceptional shift in DBLR!"
		else
			trace = W(1,1) + W(2,2)
			detm = W(1,1)*W(2,2) - W(1,2)*W(2,1)
		end if

		! Build G
		A = 0d0
		if(K == 1)then
			A(1,1) = Bands(start_index-1,1)
			A(2,2) = Bands(start_index,1)
		else
			A(1,1:2) = Bands(start_index-1,1:2)
			A(2,2) = Bands(start_index,1)
		end if

		A(2:3,:) = matmul(Blocks(:,:,start_index+1),A(2:3,:))
		A(1:2,:) = matmul(Blocks(:,:,start_index),A(1:2,:))

		G(1) = A(1,1)**2 - trace*A(1,1) + detm + A(1,2)*A(2,1)
		G(2) = A(2,1)*(A(1,1) + A(2,2) - trace)
		G(3) = A(2,1)*A(3,2)

		! Build L1 L2 and L3
		L2 = G(3)/G(2);
		L3 = G(2)/G(1);

		! Build bulge
		call DBB(L1,L2,L3,start_index,N,Blocks,init,flag)

		! Move L2 through bands
		call DBP(L2,start_index+1,start_index,stop_index,N,K,Bands)

		! Move L3 through bands
		call DBP(L3,start_index,start_index,stop_index,N,K,Bands)

		! Turnover iterations
		if(chase == 0)then
		do hh=(start_index+2),(stop_index)
			! Pass through Blocks and turnover L's over
			call DGATO(Blocks(:,:,hh-1),Blocks(:,:,hh),L2,flag)
			call DGATO(Blocks(:,:,hh-2),Blocks(:,:,hh-1),L3,flag)

			call DGLTO(L1,L2,L3,flag)

			! Move L2 through bands
			call DBP(L2,hh,start_index,stop_index,N,K,Bands)

			! Move L3 through bands
			call DBP(L3,hh-1,start_index,stop_index,N,K,Bands)

		end do

		! Dump the Bulge
		Blocks(:,1,stop_index) = Blocks(:,1,stop_index) + L2*Blocks(:,2,stop_index)

		call DGATO(Blocks(:,:,stop_index-1),Blocks(:,:,stop_index),L3,flag)

		! Move L1 through bands
		call DBP(L1,stop_index,start_index,stop_index,N,K,Bands)

		Blocks(:,1,stop_index) = Blocks(:,1,stop_index) + L1*Blocks(:,2,stop_index)

		! Move L3 through bands
		call DBP(L3,stop_index,start_index,stop_index,N,K,Bands)

		Blocks(:,1,stop_index) = Blocks(:,1,stop_index) + L3*Blocks(:,2,stop_index)

		else if(chase == 1)then
		do hh=(start_index+2),(stop_index)
			! Pass through Blocks and turnover L's over
			call DGATO(Blocks(:,:,hh-1),Blocks(:,:,hh),L2,flag)
			call DGATO(Blocks(:,:,hh-2),Blocks(:,:,hh-1),L3,flag)

			! Move L1 through bands
			call DBP(L1,hh-1,start_index,stop_index,N,K,Bands)

			! Move L2 through bands
			call DBP(L2,hh,start_index,stop_index,N,K,Bands)

			! Move L3 through bands
			call DBP(L3,hh-1,start_index,stop_index,N,K,Bands)

			! Pass L1 through Blocks
			call DGATO(Blocks(:,:,hh-1),Blocks(:,:,hh),L1,flag)

		end do

		! Dump the Bulge
		Blocks(:,1,stop_index) = Blocks(:,1,stop_index) + L2*Blocks(:,2,stop_index)

		call DGATO(Blocks(:,:,stop_index-1),Blocks(:,:,stop_index),L3,flag)

		! Move L1 through bands
		call DBP(L1,stop_index,start_index,stop_index,N,K,Bands)

		Blocks(:,1,stop_index) = Blocks(:,1,stop_index) + L1*Blocks(:,2,stop_index)

		! Move L3 through bands
		call DBP(L3,stop_index,start_index,stop_index,N,K,Bands)

		Blocks(:,1,stop_index) = Blocks(:,1,stop_index) + L3*Blocks(:,2,stop_index)

		end if
	end if

  end do

  ! set flag for maxing out loop
  if(mm == it_max)then
  	flag = 1
  end if

	! free memory
	deallocate(spike,Blocks,Bands)

end subroutine

! **********************************************************************
!
!
!
! **********************************************************************

subroutine DGATO(A,B,L,flag)

implicit none

integer :: flag
double precision :: A(2,2),B(2,2),L

	A(:,1) = A(:,1) + L*B(1,1)*A(:,2)

	if(dabs(A(2,1)) == 0)then
		flag = 1
		return
	end if

	L = L*B(2,1)/A(2,1)

	B(2,:) = B(2,:) - L*A(2,2)*B(1,:)

end subroutine

! **********************************************************************
!
!
!
! **********************************************************************

subroutine DGLTO(L1,L2,L3,flag)

implicit none

integer :: flag
double precision :: L1,L2,L3,temp1,temp2,temp3

	temp1 = L1
	temp2 = L2
	temp3 = L3

	L3 = temp1 + temp3

	if(dabs(L3) == 0)then
		write(*,*) "Tried to divide by 0. Algorithm failed!"
		flag = 1
		return
	end if

	L2 = temp2*temp3/L3
	L1 = temp2 - L2

end subroutine

! **********************************************************************
!
! Double Precision Band Pass
!
! **********************************************************************

subroutine DBP(L,start,top,bottom,N,K,Bands)

implicit none

integer :: start,top,bottom,N,K,jj,length
double precision :: L,Bands(N,K),bulge

		length = min(start-top+1,K-1)
		do jj=1,length
			Bands(start-jj,jj) = Bands(start-jj,jj) + L*Bands(start-jj,jj+1)
		end do

		bulge = L*Bands(start,1)

		L = bulge/Bands(start-1,1)

		length = min(K-1,bottom+1-start)
		do jj=1,length
			Bands(start,jj) = Bands(start,jj) - L*Bands(start-1,jj+1)
		end do

end subroutine

! **********************************************************************
!
! Double Precision Bulge Build
!
! **********************************************************************

subroutine DBB(L1,L2,L3,start,N,Blocks,switch,flag)

implicit none

integer :: start,N,switch,flag
double precision :: L1,L2,L3,Blocks(2,2,N),M,W(2,2)

		if(switch == 0)then
			W = Blocks(:,:,start)
			Blocks(2,:,start) = Blocks(2,:,start) - L3*Blocks(1,:,start)

			if(dabs(Blocks(2,1,start)) == 0)then
				flag = 1
				return
			end if

			L1 = -L2*W(2,1)/Blocks(2,1,start)
			M = -L2*W(2,2) - L1*Blocks(2,2,start)

			Blocks(2,:,start+1) = Blocks(2,:,start+1) + M*Blocks(1,:,start+1)

		else if(switch == 1)then
			Blocks(2,:,start+1) = Blocks(2,:,start+1) - L2*Blocks(2,2,start)*Blocks(1,:,start+1)

			if(dabs(Blocks(2,1,start+1)) == 0)then
				flag = 1
				return
			end if

			L1 = -L2*Blocks(2,1,start)/Blocks(2,1,start+1)

			Blocks(:,1,start)= Blocks(:,1,start) - L1*Blocks(1,1,start+1)*Blocks(:,2,start)

			Blocks(2,:,start) = Blocks(2,:,start) - L3*Blocks(1,:,start)

			call DGATO(Blocks(:,:,start),Blocks(:,:,start+1),L1,flag)

		end if

end subroutine

! **********************************************************************
!
!
!
! **********************************************************************

subroutine dnormalpoly(N,poly)

	implicit none

	integer, intent(in) :: N
	real(kind(1d0)), intent(inout) :: poly(N)

	double precision :: u,v,s,pi = 3.141592653589793239d0
	integer :: ii,jj

	poly = 0d0

	do ii=1,N
		do jj=1,20

			call random_number(u)
			call random_number(v)

			s = u**2 + v**2

			if(s > 0 .and. s < 1)then
				poly(ii) = dcos(2d0*pi*v)*dsqrt(-2d0*log(u))
				exit
			end if
		end do

	end do

end subroutine

! **********************************************************************
!
!
!
! **********************************************************************

SUBROUTINE init_random_seed()

	implicit none

        INTEGER :: ii, kk, clock
        INTEGER, DIMENSION(:), ALLOCATABLE :: seed

        CALL RANDOM_SEED(size = kk)
        ALLOCATE(seed(kk))

        CALL SYSTEM_CLOCK(COUNT=clock)

        seed = clock + 37 * (/ (ii - 1, ii = 1, kk) /)
        CALL RANDOM_SEED(PUT = seed)

	DEALLOCATE(seed)
END SUBROUTINE


program problem52
  implicit none
  integer*8 :: i

  do i = 1,huge(i)
     if (predicate(i)) then
        exit
     end if
  end do

  print *, i

contains

  pure function score(n)
    implicit none
    integer*8, intent(in)             :: n
    integer*8                         :: temp,score
    integer, parameter, dimension(10) :: primes = [ 2, 3, 5, 7, 11, 13, 17, 19, 23, 29 ]

    score=1
    temp=n
    do while (temp > 0)
       score=score*primes(mod(temp,10)+1)
       temp=temp/10
    end do

  end function score

  pure function predicate(n)
    implicit none
    integer*8, intent(in) :: n
    integer*8             :: temp1
    logical, dimension(5) :: temp2
    logical               :: predicate

    temp1=score(n)
    temp2=(/ (score(n*i) == temp1, i = 2, 6) /)
    predicate=all(temp2)

  end function predicate

end program problem52


    Program dgtcon_example

!     DGTCON 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 lapack_interfaces, Only: dgtcon, dgttrf, dlangt
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: anorm, rcond
      Integer :: info, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: d(:), dl(:), du(:), du2(:), work(:)
      Integer, Allocatable :: ipiv(:), iwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: epsilon
!     .. Executable Statements ..
      Write (nout, *) 'DGTCON Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n

      Allocate (d(n), dl(n-1), du(n-1), du2(n-2), work(2*n), ipiv(n), &
        iwork(n))

!     Read the tridiagonal matrix A from data file

      Read (nin, *) du(1:n-1)
      Read (nin, *) d(1:n)
      Read (nin, *) dl(1:n-1)

!     Compute the 1-norm of A
      anorm = dlangt('1-norm', n, dl, d, du)

!     Factorize the tridiagonal matrix A
      Call dgttrf(n, dl, d, du, du2, ipiv, info)

      If (info==0) Then

!       Estimate the condition number of A
        Call dgtcon('1-norm', n, dl, d, du, du2, ipiv, anorm, rcond, work, &
          iwork, info)

!       Print the estimated condition number

        If (rcond>=epsilon(1.0E0_dp)) Then
          Write (nout, 100) 'Estimate of condition number = ', 1.0_dp/rcond
        Else
          Write (nout, 100) 'A is singular to working precision. RCOND = ', &
            rcond
        End If

      Else
        Write (nout, 110) 'The (', info, ',', info, ')', &
          ' element of the factor U is zero'
      End If

100   Format (1X, A, 1P, E10.2)
110   Format (1X, A, I3, A, I3, A, A)
    End Program


	SUBROUTINE GCFPAR  ( xx, yy, c, iret )
C************************************************************************
C* GCFPAR								*
C*									*
C* This subroutine fits a second degree polynomial to three points.	*
C* It is called by the cubic spline program.  Therefore, coefficients	*
C* for the two segments are returned as third degree polynomial 	*
C* coefficients with the cubic term set to 0.				*
C*									*
C* GCFPAR ( XX, YY, C, IRET )						*
C*									*
C* Input parameters:							*
C*	XX (3)		REAL		Input x coordinates		*
C*	YY (3)		REAL		Input y coordinates		*
C*									*
C* Output parameters:							*
C*	C (4,2)		REAL		Coefficients			*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	12/85						*
C* T. Lee/GSC		 9/97	Included ERROR.PRM			*
C************************************************************************
	INCLUDE		'ERROR.PRM'
C*
	REAL		xx (*), yy (*), c (4,*)
C------------------------------------------------------------------------
	iret = NOPNTS
C
C*	Do the computations for the first interval.
C
	y1 = yy (1)
	y2 = yy (2)
	y3 = yy (3)
	x1 = 0.
	x2 = xx (2) - xx (1)
	x3 = xx (3) - xx (1)
	y2y1 = y2 - y1
	y3y1 = y3 - y1
	y2y1x3 = y2y1 * x3
	y3y1x2 = y3y1 * x2
	fac = x3**2 * x2 - x2**2 * x3
	IF  ( fac .eq. 0. ) RETURN
	ca = ( y3y1x2 - y2y1x3 ) / fac
	cb = ( y2y1 - ca * x2**2 ) / x2
	c (1,1) = 0
	c (2,1) = ca
	c (3,1) = cb
	c (4,1) = y1
C
C*	Do the computations in the second interval.
C
	x1 = xx (2) - xx (1)
	x2 = 0
	x3 = xx (3) - xx (1)
	y1y2 = y1 - y2
	y3y2 = y3 - y2
	y1y2x3 = y1y2 * x3
	y3y2x1 = y3y2 * x1
	fac = x3**2 * x1 - x1**2 * x3
	IF  ( fac .eq. 0. ) RETURN
	ca = ( y3y2x1 - y1y2x3 ) / fac
	cb = ( y1y2 - ca * x1**2 ) / x1
	c (1,2) = 0
	c (2,2) = ca
	c (3,2) = cb
	c (4,2) = y2
C*
	RETURN
	END


	program matrix
	parameter (n=700)
	real a(n,n), b(n,n), c(n,n)

c initialise
	do i=1,n
	  do j=1,n
	    a(i,j) = 1.0/float(i+j)
	    b(i,j) = 1.0/float(i) + 1.0/float(j)
	  enddo
	enddo

	do i=1,n
	  do j=1,n
	    c(i,j) = 0.0
	    do k=1,n
	      c(i,j) = c(i,j) + a(i,k)*b(k,j)
	    enddo
	  enddo
	enddo
	print*,c(10,10)
	stop
	end