C
C     file hwscrt.f
C
      SUBROUTINE HWSCRT (A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,
     1                   ELMBDA,F,IDIMF,PERTRB,IERROR,W)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C
C DIMENSION OF           BDA(N),      BDB(N),   BDC(M),BDD(M),
C ARGUMENTS              F(IDIMF,N),  W(SEE ARGUMENT LIST)
C
C LATEST REVISION        NOVEMBER 1988
C
C PURPOSE                SOLVES THE STANDARD FIVE-POINT FINITE
C                        DIFFERENCE APPROXIMATION TO THE HELMHOLTZ
C                        EQUATION IN CARTESIAN COORDINATES.  THIS
C                        EQUATION IS
C
C                          (D/DX)(DU/DX) + (D/DY)(DU/DY)
C                          + LAMBDA*U = F(X,Y).
C
C USAGE                  CALL HWSCRT (A,B,M,MBDCND,BDA,BDB,C,D,N,
C                                     NBDCND,BDC,BDD,ELMBDA,F,IDIMF,
C                                     PERTRB,IERROR,W)
C
C ARGUMENTS
C ON INPUT               A,B
C
C                          THE RANGE OF X, I.E., A .LE. X .LE. B.
C                          A MUST BE LESS THAN B.
C
C                        M
C                          THE NUMBER OF PANELS INTO WHICH THE
C                          INTERVAL (A,B) IS SUBDIVIDED.
C                          HENCE, THERE WILL BE M+1 GRID POINTS
C                          IN THE X-DIRECTION GIVEN BY
C                          X(I) = A+(I-1)DX FOR I = 1,2,...,M+1,
C                          WHERE DX = (B-A)/M IS THE PANEL WIDTH.
C                          M MUST BE GREATER THAN 3.
C
C                        MBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITIONS
C                          AT X = A AND X = B.
C
C                          = 0  IF THE SOLUTION IS PERIODIC IN X,
C                               I.E., U(I,J) = U(M+I,J).
C                          = 1  IF THE SOLUTION IS SPECIFIED AT
C                               X = A AND X = B.
C                          = 2  IF THE SOLUTION IS SPECIFIED AT
C                               X = A AND THE DERIVATIVE OF THE
C                               SOLUTION WITH RESPECT TO X IS
C                               SPECIFIED AT X = B.
C                          = 3  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO X IS SPECIFIED AT
C                               AT X = A AND X = B.
C                          = 4  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO X IS SPECIFIED AT
C                               X = A AND THE SOLUTION IS SPECIFIED
C                               AT X = B.
C
C                        BDA
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT
C                          SPECIFIES THE VALUES OF THE DERIVATIVE
C                          OF THE SOLUTION WITH RESPECT TO X AT X = A.
C
C                          WHEN MBDCND = 3 OR 4,
C
C                            BDA(J) = (D/DX)U(A,Y(J)), J = 1,2,...,N+1.
C
C                          WHEN MBDCND HAS ANY OTHER VALUE, BDA IS
C                          A DUMMY VARIABLE.
C
C                        BDB
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N+1
C                          THAT SPECIFIES THE VALUES OF THE DERIVATIVE
C                          OF THE SOLUTION WITH RESPECT TO X AT X = B.
C
C                          WHEN MBDCND = 2 OR 3,
C
C                            BDB(J) = (D/DX)U(B,Y(J)), J = 1,2,...,N+1
C
C                          WHEN MBDCND HAS ANY OTHER VALUE BDB IS A
C                          DUMMY VARIABLE.
C
C                        C,D
C                          THE RANGE OF Y, I.E., C .LE. Y .LE. D.
C                          C MUST BE LESS THAN D.
C
C                        N
C                          THE NUMBER OF PANELS INTO WHICH THE
C                          INTERVAL (C,D) IS SUBDIVIDED.  HENCE,
C                          THERE WILL BE N+1 GRID POINTS IN THE
C                          Y-DIRECTION GIVEN BY Y(J) = C+(J-1)DY
C                          FOR J = 1,2,...,N+1, WHERE
C                          DY = (D-C)/N IS THE PANEL WIDTH.
C                          N MUST BE GREATER THAN 3.
C
C                        NBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITIONS AT
C                          Y = C AND Y = D.
C
C                          = 0  IF THE SOLUTION IS PERIODIC IN Y,
C                               I.E., U(I,J) = U(I,N+J).
C                          = 1  IF THE SOLUTION IS SPECIFIED AT
C                               Y = C AND Y = D.
C                          = 2  IF THE SOLUTION IS SPECIFIED AT
C                               Y = C AND THE DERIVATIVE OF THE
C                               SOLUTION WITH RESPECT TO Y IS
C                               SPECIFIED AT Y = D.
C                          = 3  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO Y IS SPECIFIED AT
C                               Y = C AND Y = D.
C                          = 4  IF THE DERIVATIVE OF THE SOLUTION
C                               WITH RESPECT TO Y IS SPECIFIED AT
C                               Y = C AND THE SOLUTION IS SPECIFIED
C                               AT Y = D.
C
C                        BDC
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT
C                          SPECIFIES THE VALUES OF THE DERIVATIVE
C                          OF THE SOLUTION WITH RESPECT TO Y AT Y = C.
C
C                          WHEN NBDCND = 3 OR 4,
C
C                            BDC(I) = (D/DY)U(X(I),C), I = 1,2,...,M+1
C
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDC IS
C                          A DUMMY VARIABLE.
C
C                        BDD
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT
C                          SPECIFIES THE VALUES OF THE DERIVATIVE
C                          OF THE SOLUTION WITH RESPECT TO Y AT Y = D.
C
C                          WHEN NBDCND = 2 OR 3,
C
C                            BDD(I) = (D/DY)U(X(I),D), I = 1,2,...,M+1
C
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDD IS
C                          A DUMMY VARIABLE.
C
C                        ELMBDA
C                          THE CONSTANT LAMBDA IN THE HELMHOLTZ
C                          EQUATION.  IF LAMBDA .GT. 0, A SOLUTION
C                          MAY NOT EXIST.  HOWEVER, HWSCRT WILL
C                          ATTEMPT TO FIND A SOLUTION.
C
C                        F
C                          A TWO-DIMENSIONAL ARRAY, OF DIMENSION AT
C                          LEAST (M+1)*(N+1), SPECIFYING VALUES OF THE
C                          RIGHT SIDE OF THE HELMHOLTZ  EQUATION AND
C                          BOUNDARY VALUES (IF ANY).
C
C                          ON THE INTERIOR, F IS DEFINED AS FOLLOWS:
C                          FOR I = 2,3,...,M AND J = 2,3,...,N
C                          F(I,J) = F(X(I),Y(J)).
C
C                          ON THE BOUNDARIES, F IS DEFINED AS FOLLOWS:
C                          FOR J=1,2,...,N+1,  I=1,2,...,M+1,
C
C                          MBDCND     F(1,J)        F(M+1,J)
C                          ------     ---------     --------
C
C                            0        F(A,Y(J))     F(A,Y(J))
C                            1        U(A,Y(J))     U(B,Y(J))
C                            2        U(A,Y(J))     F(B,Y(J))
C                            3        F(A,Y(J))     F(B,Y(J))
C                            4        F(A,Y(J))     U(B,Y(J))
C
C
C                          NBDCND     F(I,1)        F(I,N+1)
C                          ------     ---------     --------
C
C                            0        F(X(I),C)     F(X(I),C)
C                            1        U(X(I),C)     U(X(I),D)
C                            2        U(X(I),C)     F(X(I),D)
C                            3        F(X(I),C)     F(X(I),D)
C                            4        F(X(I),C)     U(X(I),D)
C
C                          NOTE:
C                          IF THE TABLE CALLS FOR BOTH THE SOLUTION U
C                          AND THE RIGHT SIDE F AT A CORNER THEN THE
C                          SOLUTION MUST BE SPECIFIED.
C
C                        IDIMF
C                          THE ROW (OR FIRST) DIMENSION OF THE ARRAY
C                          F AS IT APPEARS IN THE PROGRAM CALLING
C                          HWSCRT.  THIS PARAMETER IS USED TO SPECIFY
C                          THE VARIABLE DIMENSION OF F.  IDIMF MUST
C                          BE AT LEAST M+1  .
C
C                        W
C                          A ONE-DIMENSIONAL ARRAY THAT MUST BE
C                          PROVIDED BY THE USER FOR WORK SPACE.
C                          W MAY REQUIRE UP TO 4*(N+1) +
C                          (13 + INT(LOG2(N+1)))*(M+1) LOCATIONS.
C                          THE ACTUAL NUMBER OF LOCATIONS USED IS
C                          COMPUTED BY HWSCRT AND IS RETURNED IN
C                          LOCATION W(1).
C
C
C ON OUTPUT              F
C                          CONTAINS THE SOLUTION U(I,J) OF THE FINITE
C                          DIFFERENCE APPROXIMATION FOR THE GRID POINT
C                          (X(I),Y(J)), I = 1,2,...,M+1,
C                          J = 1,2,...,N+1  .
C
C                        PERTRB
C                          IF A COMBINATION OF PERIODIC OR DERIVATIVE
C                          BOUNDARY CONDITIONS IS SPECIFIED FOR A
C                          POISSON EQUATION (LAMBDA = 0), A SOLUTION
C                          MAY NOT EXIST.  PERTRB IS A CONSTANT,
C                          CALCULATED AND SUBTRACTED FROM F, WHICH
C                          ENSURES THAT A SOLUTION EXISTS.  HWSCRT
C                          THEN COMPUTES THIS SOLUTION, WHICH IS A
C                          LEAST SQUARES SOLUTION TO THE ORIGINAL
C                          APPROXIMATION.  THIS SOLUTION PLUS ANY
C                          CONSTANT IS ALSO A SOLUTION.  HENCE, THE
C                          SOLUTION IS NOT UNIQUE.  THE VALUE OF
C                          PERTRB SHOULD BE SMALL COMPARED TO THE
C                          RIGHT SIDE F.  OTHERWISE, A SOLUTION IS
C                          OBTAINED TO AN ESSENTIALLY DIFFERENT
C                          PROBLEM. THIS COMPARISON SHOULD ALWAYS
C                          BE MADE TO INSURE THAT A MEANINGFUL
C                          SOLUTION HAS BEEN OBTAINED.
C
C                        IERROR
C                          AN ERROR FLAG THAT INDICATES INVALID INPUT
C                          PARAMETERS.  EXCEPT FOR NUMBERS 0 AND 6,
C                          A SOLUTION IS NOT ATTEMPTED.
C
C                          = 0  NO ERROR
C                          = 1  A .GE. B
C                          = 2  MBDCND .LT. 0 OR MBDCND .GT. 4
C                          = 3  C .GE. D
C                          = 4  N .LE. 3
C                          = 5  NBDCND .LT. 0 OR NBDCND .GT. 4
C                          = 6  LAMBDA .GT. 0
C                          = 7  IDIMF .LT. M+1
C                          = 8  M .LE. 3
C
C                          SINCE THIS IS THE ONLY MEANS OF INDICATING
C                          A POSSIBLY INCORRECT CALL TO HWSCRT, THE
C                          USER SHOULD TEST IERROR AFTER THE CALL.
C
C                        W
C                          W(1) CONTAINS THE REQUIRED LENGTH OF W.
C
C SPECIAL CONDITIONS     NONE
C
C I/O                    NONE
C
C PRECISION              SINGLE
C
C REQUIRED LIBRARY       GENBUN, GNBNAUX, AND COMF
C FILES                  FROM FISHPACK
C
C LANGUAGE               FORTRAN
C
C HISTORY                WRITTEN BY ROLAND SWEET AT NCAR IN THE LATE
C                        1970'S.  RELEASED ON NCAR'S PUBLIC SOFTWARE
C                        LIBRARIES IN JANUARY 1980.
C
C PORTABILITY            FORTRAN 77
C
C ALGORITHM              THE ROUTINE DEFINES THE FINITE DIFFERENCE
C                        EQUATIONS, INCORPORATES BOUNDARY DATA, AND
C                        ADJUSTS THE RIGHT SIDE OF SINGULAR SYSTEMS
C                        AND THEN CALLS GENBUN TO SOLVE THE SYSTEM.
C
C TIMING                 FOR LARGE  M AND N, THE OPERATION COUNT
C                        IS ROUGHLY PROPORTIONAL TO
C                          M*N*(LOG2(N)
C                        BUT ALSO DEPENDS ON INPUT PARAMETERS NBDCND
C                        AND MBDCND.
C
C ACCURACY               THE SOLUTION PROCESS EMPLOYED RESULTS IN A LOSS
C                        OF NO MORE THAN THREE SIGNIFICANT DIGITS FOR N
C                        AND M AS LARGE AS 64.  MORE DETAILS ABOUT
C                        ACCURACY CAN BE FOUND IN THE DOCUMENTATION FOR
C                        SUBROUTINE GENBUN WHICH IS THE ROUTINE THAT
C                        SOLVES THE FINITE DIFFERENCE EQUATIONS.
C
C REFERENCES             SWARZTRAUBER,P. AND R. SWEET, "EFFICIENT
C                        FORTRAN SUBPROGRAMS FOR THE SOLUTION OF
C                        ELLIPTIC EQUATIONS"
C                          NCAR TN/IA-109, JULY, 1975, 138 PP.
C***********************************************************************
      DIMENSION       F(IDIMF,*)
      DIMENSION       BDA(*)     ,BDB(*)     ,BDC(*)     ,BDD(*)     ,
     1                W(*)
C
C     CHECK FOR INVALID PARAMETERS.
C
      IERROR = 0
      IF (A .GE. B) IERROR = 1
      IF (MBDCND.LT.0 .OR. MBDCND.GT.4) IERROR = 2
      IF (C .GE. D) IERROR = 3
      IF (N .LE. 3) IERROR = 4
      IF (NBDCND.LT.0 .OR. NBDCND.GT.4) IERROR = 5
      IF (IDIMF .LT. M+1) IERROR = 7
      IF (M .LE. 3) IERROR = 8
      IF (IERROR .NE. 0) RETURN
      NPEROD = NBDCND
      MPEROD = 0
      IF (MBDCND .GT. 0) MPEROD = 1
      DELTAX = (B-A)/FLOAT(M)
      TWDELX = 2./DELTAX
      DELXSQ = 1./DELTAX**2
      DELTAY = (D-C)/FLOAT(N)
      TWDELY = 2./DELTAY
      DELYSQ = 1./DELTAY**2
      NP = NBDCND+1
      NP1 = N+1
      MP = MBDCND+1
      MP1 = M+1
      NSTART = 1
      NSTOP = N
      NSKIP = 1
      GO TO (104,101,102,103,104),NP
  101 NSTART = 2
      GO TO 104
  102 NSTART = 2
  103 NSTOP = NP1
      NSKIP = 2
  104 NUNK = NSTOP-NSTART+1
C
C     ENTER BOUNDARY DATA FOR X-BOUNDARIES.
C
      MSTART = 1
      MSTOP = M
      MSKIP = 1
      GO TO (117,105,106,109,110),MP
  105 MSTART = 2
      GO TO 107
  106 MSTART = 2
      MSTOP = MP1
      MSKIP = 2
  107 DO 108 J=NSTART,NSTOP
         F(2,J) = F(2,J)-F(1,J)*DELXSQ
  108 CONTINUE
      GO TO 112
  109 MSTOP = MP1
      MSKIP = 2
  110 DO 111 J=NSTART,NSTOP
         F(1,J) = F(1,J)+BDA(J)*TWDELX
  111 CONTINUE
  112 GO TO (113,115),MSKIP
  113 DO 114 J=NSTART,NSTOP
         F(M,J) = F(M,J)-F(MP1,J)*DELXSQ
  114 CONTINUE
      GO TO 117
  115 DO 116 J=NSTART,NSTOP
         F(MP1,J) = F(MP1,J)-BDB(J)*TWDELX
  116 CONTINUE
  117 MUNK = MSTOP-MSTART+1
C
C     ENTER BOUNDARY DATA FOR Y-BOUNDARIES.
C
      GO TO (127,118,118,120,120),NP
  118 DO 119 I=MSTART,MSTOP
         F(I,2) = F(I,2)-F(I,1)*DELYSQ
  119 CONTINUE
      GO TO 122
  120 DO 121 I=MSTART,MSTOP
         F(I,1) = F(I,1)+BDC(I)*TWDELY
  121 CONTINUE
  122 GO TO (123,125),NSKIP
  123 DO 124 I=MSTART,MSTOP
         F(I,N) = F(I,N)-F(I,NP1)*DELYSQ
  124 CONTINUE
      GO TO 127
  125 DO 126 I=MSTART,MSTOP
         F(I,NP1) = F(I,NP1)-BDD(I)*TWDELY
  126 CONTINUE
C
C    MULTIPLY RIGHT SIDE BY DELTAY**2.
C
  127 DELYSQ = DELTAY*DELTAY
      DO 129 I=MSTART,MSTOP
         DO 128 J=NSTART,NSTOP
            F(I,J) = F(I,J)*DELYSQ
  128    CONTINUE
  129 CONTINUE
C
C     DEFINE THE A,B,C COEFFICIENTS IN W-ARRAY.
C
      ID2 = MUNK
      ID3 = ID2+MUNK
      ID4 = ID3+MUNK
      S = DELYSQ*DELXSQ
      ST2 = 2.*S
      DO 130 I=1,MUNK
         W(I) = S
         J = ID2+I
         W(J) = -ST2+ELMBDA*DELYSQ
         J = ID3+I
         W(J) = S
  130 CONTINUE
      IF (MP .EQ. 1) GO TO 131
      W(1) = 0.
      W(ID4) = 0.
  131 CONTINUE
      GO TO (135,135,132,133,134),MP
  132 W(ID2) = ST2
      GO TO 135
  133 W(ID2) = ST2
  134 W(ID3+1) = ST2
  135 CONTINUE
      PERTRB = 0.
      IF (ELMBDA) 144,137,136
  136 IERROR = 6
      GO TO 144
  137 IF ((NBDCND.EQ.0 .OR. NBDCND.EQ.3) .AND.
     1    (MBDCND.EQ.0 .OR. MBDCND.EQ.3)) GO TO 138
      GO TO 144
C
C     FOR SINGULAR PROBLEMS MUST ADJUST DATA TO INSURE THAT A SOLUTION
C     WILL EXIST.
C
  138 A1 = 1.
      A2 = 1.
      IF (NBDCND .EQ. 3) A2 = 2.
      IF (MBDCND .EQ. 3) A1 = 2.
      S1 = 0.
      MSP1 = MSTART+1
      MSTM1 = MSTOP-1
      NSP1 = NSTART+1
      NSTM1 = NSTOP-1
      DO 140 J=NSP1,NSTM1
         S = 0.
         DO 139 I=MSP1,MSTM1
            S = S+F(I,J)
  139    CONTINUE
         S1 = S1+S*A1+F(MSTART,J)+F(MSTOP,J)
  140 CONTINUE
      S1 = A2*S1
      S = 0.
      DO 141 I=MSP1,MSTM1
         S = S+F(I,NSTART)+F(I,NSTOP)
  141 CONTINUE
      S1 = S1+S*A1+F(MSTART,NSTART)+F(MSTART,NSTOP)+F(MSTOP,NSTART)+
     1     F(MSTOP,NSTOP)
      S = (2.+FLOAT(NUNK-2)*A2)*(2.+FLOAT(MUNK-2)*A1)
      PERTRB = S1/S
      DO 143 J=NSTART,NSTOP
         DO 142 I=MSTART,MSTOP
            F(I,J) = F(I,J)-PERTRB
  142    CONTINUE
  143 CONTINUE
      PERTRB = PERTRB/DELYSQ
C
C     SOLVE THE EQUATION.
C
  144 CALL GENBUN (NPEROD,NUNK,MPEROD,MUNK,W(1),W(ID2+1),W(ID3+1),
     1             IDIMF,F(MSTART,NSTART),IERR1,W(ID4+1))
      W(1) = W(ID4+1)+3.*FLOAT(MUNK)
C
C     FILL IN IDENTICAL VALUES WHEN HAVE PERIODIC BOUNDARY CONDITIONS.
C
      IF (NBDCND .NE. 0) GO TO 146
      DO 145 I=MSTART,MSTOP
         F(I,NP1) = F(I,1)
  145 CONTINUE
  146 IF (MBDCND .NE. 0) GO TO 148
      DO 147 J=NSTART,NSTOP
         F(MP1,J) = F(1,J)
  147 CONTINUE
      IF (NBDCND .EQ. 0) F(MP1,NP1) = F(1,NP1)
  148 CONTINUE
      RETURN
C
C REVISION HISTORY---
C
C SEPTEMBER 1973    VERSION 1
C APRIL     1976    VERSION 2
C JANUARY   1978    VERSION 3
C DECEMBER  1979    VERSION 3.1
C FEBRUARY  1985    DOCUMENTATION UPGRADE
C NOVEMBER  1988    VERSION 3.2, FORTRAN 77 CHANGES
C-----------------------------------------------------------------------
      END


      SUBROUTINE APLMS(L,M,S,AP)

!PURPOSE: Compute A'(l,m,s)

      INCLUDE       '../INCLDS/COPYRIGT.FOR'

!CALLING ARGUMENTS:

      INTEGER*4     L,M,S               !Order & subindices
      REAL*4        AP                  !Output value

!INCLUDE STATEMENTS:

!LOCAL VARIABLES:

      REAL*4        LNORM,ALM0S,A1,A2

!FUNCTION DEFINITIONS:

!DATA STATEMENTS:

!CODE:

      LNORM = SQRT((2.0*L+1.0)/2.0)
      CALL QLMN(L,M,S,A1)
      CALL QLMN(L,0,S,A2)
      ALM0S = A1*A2
      IF ( MOD(ABS(M),2).EQ.0 ) THEN
        IF ( S.EQ.0 ) THEN
          AP = ALM0S*LNORM
        ELSE
          AP = 2.0*ALM0S*LNORM
        END IF
        IF ( MOD(ABS(M),4).EQ.2 ) AP = -AP
      ELSE
        IF ( S.EQ.0 ) THEN
          AP = 0.0
        ELSE
          AP = 2.0*ALM0S*LNORM
        END IF
        IF ( MOD(ABS(M),4).EQ.1 ) AP = -AP
      END IF
      IF ( ABS(AP).LT.1.0E-6 ) AP = 0.0
      RETURN
      END


c_______________________________________________________________________
c
        subroutine matmult(a,b,c,nn,np,nq)

c       multiplies n x p matrix a by p x q matrix b and puts result in c

        real a(nn,np),b(np,nq),c(nn,nq)

        do 10 in=1,nn
        do 10 iq=1,nq
        temp=0.

           do  5 ip=1,np
5          temp=temp+a(in,ip)*b(ip,iq)

10      c(in,iq)=temp
        return
        end
c______________________________________________________________________
c
        subroutine matmultc(a,b,c,nn,np,nq)

c       multiplies n x p matrix a by p x q matrix b and puts result in c
c       complex version

        complex a(nn,np),b(np,nq),c(nn,nq),temp

        do 10 in=1,nn
        do 10 iq=1,nq
        temp=0.

           do  5 ip=1,np
5          temp=temp+a(in,ip)*b(ip,iq)

10      c(in,iq)=temp
        return
        end
c______________________________________________________________________
c
        subroutine mmacb(a,b,c,nn,np,nq)

c       multiplies conjugate transpose of
c         p x n matrix a by p x q matrix b and puts result in c
c       complex version

        complex a(np,nn),b(np,nq),c(nn,nq),temp

        do 10 in=1,nn
        do 10 iq=1,nq
        temp=0.

           do  5 ip=1,np
5          temp=temp+conjg(a(ip,in))*b(ip,iq)

10      c(in,iq)=temp
        return
        end
c______________________________________________________________________
c
        subroutine mmabc(a,b,c,nn,np,nq)

c       multiplies n x p matrix a by conjugate transpose of
c           q x p matrix b and puts result in c
c       complex version

        complex a(nn,np),b(nq,np),c(nn,nq),temp

        do 10 in=1,nn
        do 10 iq=1,nq
        temp=0.

           do  5 ip=1,np
5          temp=temp+a(in,ip)*conjg(b(iq,ip))

10      c(in,iq)=temp
        return
        end


module mod_parallel
  !< Summary: Provide parallel functions for domain decomposition
  !<          using coarrays
  !< Author: Milan Curic (Initial), Sam Miller (Adapted and extended)
  !< Notes: Adapted from https://github.com/modern-fortran/tsunami/

  use, intrinsic :: iso_fortran_env, only: ik => int32, rk => real64, int64, std_out => output_unit

  implicit none

  ! private
  ! public :: num_2d_tiles, tile_indices, tile_neighbors_1d, tile_neighbors_2d !, sync_edges

  interface tile_indices
    module procedure :: tile_indices_1d, tile_indices_2d
  endinterface tile_indices

  ! Neighbor image indices
  integer(ik), parameter, public :: LOWER_LEFT = 1  !< lower left neighbor image
  integer(ik), parameter, public :: DOWN = 2        !< neighbor image below
  integer(ik), parameter, public :: LOWER_RIGHT = 3 !< lower right neigbor image
  integer(ik), parameter, public :: LEFT = 4        !< neighbor image to the left
  integer(ik), parameter, public :: RIGHT = 5       !< neighbor image to the right
  integer(ik), parameter, public :: UPPER_LEFT = 6  !< upper left neighbor image
  integer(ik), parameter, public :: UP = 7          !< neighbor image above
  integer(ik), parameter, public :: UPPER_RIGHT = 8 !< upper right neighbor image

contains

  pure function denominators(n)
    ! Returns all common denominators of n.
    integer(ik), intent(in) :: n
    integer(ik), allocatable :: denominators(:)
    integer(ik) :: i
    denominators = [integer(ik) ::]
    do i = 1, n
      if(mod(n, i) == 0) denominators = [denominators, i]
    enddo
  endfunction denominators

  pure function num_2d_tiles(n)
    !< Returns the optimal number of tiles in 2 dimensions
    !< given total number of tiles n.
    !
    ! Examples:
    !   * num_2d_tiles(1) = [1, 1]
    !   * num_2d_tiles(2) = [2, 1]
    !   * num_2d_tiles(3) = [3, 1]
    !   * num_2d_tiles(4) = [2, 2]
    !   * num_2d_tiles(5) = [5, 1]
    !   * num_2d_tiles(6) = [3, 2]
    !
    integer(ik), intent(in) :: n !< # of images
    integer(ik) :: num_2d_tiles(2) !< (i, j); # of tiles in each dimension
    integer(ik), allocatable :: denoms(:)
    integer(ik), allocatable :: dim1(:), dim2(:)
    integer(ik) :: i, j, n1, n2

    ! find all common denominators of the total number of images
    denoms = denominators(n)

    ! find all combinations of common denominators
    ! whose product equals the total number of images
    dim1 = [integer(ik) ::]
    dim2 = [integer(ik) ::]
    do j = 1, size(denoms)
      do i = 1, size(denoms)
        if(denoms(i) * denoms(j) == n) then
          dim1 = [dim1, denoms(i)]
          dim2 = [dim2, denoms(j)]
        endif
      enddo
    enddo

    ! pick the set of common denominators with the minimal norm
    ! between two elements -- rectangle closest to a square
    num_2d_tiles = [dim1(1), dim2(1)]
    do i = 2, size(dim1)
      n1 = norm2([dim1(i), dim2(i)] - sqrt(real(n)))
      n2 = norm2(num_2d_tiles - sqrt(real(n)))
      if(n1 < n2) num_2d_tiles = [dim1(i), dim2(i)]
    enddo
  endfunction num_2d_tiles

  pure function num_3d_tiles(n)
    integer(ik), intent(in) :: n
    integer(ik) :: num_3d_tiles(3)
    integer(ik), allocatable :: denoms(:)
    integer(ik), allocatable :: dim1(:), dim2(:), dim3(:)
    integer(ik) :: i, j, k, n1, n2, n3
  endfunction num_3d_tiles

  pure function tile_indices_1d(dims, i, n) result(indices)
    ! Given input global array size, return start and end index
    ! of a parallel 1-d tile that correspond to this image.
    integer(ik), intent(in) :: dims, i, n
    integer(ik) :: indices(2)
    integer(ik) :: offset, tile_size

    tile_size = dims / n

    ! start and end indices assuming equal tile sizes
    indices(1) = (i - 1) * tile_size + 1
    indices(2) = indices(1) + tile_size - 1

    ! if we have any remainder, distribute it to the tiles at the end
    offset = n - mod(dims, n)
    if(i > offset) then
      indices(1) = indices(1) + i - offset - 1
      indices(2) = indices(2) + i - offset
    endif
  endfunction tile_indices_1d

  pure function tile_indices_2d(dims) result(indices)
    ! Given an input x- and y- dimensions of the total computational domain [im, jm].
    ! returns an array of start and end indices in x- and y-, [is, ie, js, je].
    integer(ik), intent(in) :: dims(2)
    integer(ik) :: indices(4)
    integer(ik) :: tiles(2), tiles_ij(2)
    tiles = num_2d_tiles(num_images())
    tiles_ij = tile_n2ij(this_image())
    indices(1:2) = tile_indices_1d(dims(1), tiles_ij(1), tiles(1))
    indices(3:4) = tile_indices_1d(dims(2), tiles_ij(2), tiles(2))
  endfunction tile_indices_2d

  pure function tile_indices_3d(dims) result(indices)
    ! Given an input x,y,z dimensions of the total computational domain [im, jm, km].
    ! returns an array of start and end indices in x,y,z : [is, ie, js, je, ks, ke].
    integer(ik), intent(in) :: dims(3)
    integer(ik) :: indices(4)
    integer(ik) :: tiles(3), tiles_ijk(3)
    ! tiles = num_3d_tiles(num_images())
    ! tiles_ij = tile_n2ij(this_image())
    ! indices(1:2) = tile_indices_1d(dims(1), tiles_ij(1), tiles(1))
    ! indices(3:4) = tile_indices_1d(dims(2), tiles_ij(2), tiles(2))
  endfunction tile_indices_3d

  pure function tile_neighbors_1d() result(neighbors)
    ! Returns the image indices corresponding
    ! to left and right neighbor tiles.
    integer(ik) :: neighbors(2)
    integer(ik) :: left, right
    if(num_images() > 1) then
      left = this_image() - 1
      right = this_image() + 1
      if(this_image() == 1) then
        left = num_images()
      else if(this_image() == num_images()) then
        right = 1
      endif
    else
      left = 1
      right = 1
    endif
    neighbors = [left, right]
  endfunction tile_neighbors_1d

  pure function tile_neighbors_2d(is_periodic) result(neighbors)
    ! Returns the neighbor image indices given.
    logical, intent(in) :: is_periodic
    integer(ik) :: neighbors(8) !< (lower_left, down, lower_right, left, right, upper_left, up, upper_right)
    integer(ik) :: tiles(2), tiles_ij(2), itile, jtile
    integer(ik) :: left, right, down, up
    integer(ik) :: lower_left  !< image # to the lower left corner
    integer(ik) :: lower_right !< image # to the lower right corner
    integer(ik) :: upper_left  !< image # to the upper left corner
    integer(ik) :: upper_right !< image # to the upper right corner
    integer(ik), dimension(2) :: ij_left  !< (i, j); index of the tile to the left
    integer(ik), dimension(2) :: ij_right !< (i, j); index of the tile to the right
    integer(ik), dimension(2) :: ij_down  !< (i, j); index of the tile below
    integer(ik), dimension(2) :: ij_up    !< (i, j); index of the tile above
    integer(ik), dimension(2) :: ij_lower_left  !< (i, j); index of the tile to the lower left corner
    integer(ik), dimension(2) :: ij_upper_left  !< (i, j); index of the tile to the upper left corner
    integer(ik), dimension(2) :: ij_lower_right !< (i, j); index of the tile to the lower right corner
    integer(ik), dimension(2) :: ij_upper_right !< (i, j); index of the tile to the upper right corner

    tiles = num_2d_tiles(num_images())
    tiles_ij = tile_n2ij(this_image())
    itile = tiles_ij(1)
    jtile = tiles_ij(2)

    ! i, j tile indices for each of the neighbors
    ij_left = [itile - 1, jtile]
    ij_upper_left = [itile - 1, jtile + 1]
    ij_lower_left = [itile - 1, jtile - 1]

    ij_right = [itile + 1, jtile]
    ij_upper_right = [itile + 1, jtile + 1]
    ij_lower_right = [itile + 1, jtile - 1]

    ij_down = [itile, jtile - 1]
    ij_up = [itile, jtile + 1]

    if(is_periodic) then
      ! set neighbor to wrap around the edge
      if(ij_left(1) < 1) ij_left(1) = tiles(1)
      if(ij_right(1) > tiles(1)) ij_right(1) = 1
      if(ij_down(2) < 1) ij_down(2) = tiles(2)
      if(ij_up(2) > tiles(2)) ij_up(2) = 1

      if(ij_lower_left(1) < 1) ij_lower_left(1) = tiles(1)
      if(ij_lower_left(2) < 1) ij_lower_left(2) = tiles(2)
      if(ij_upper_left(1) < 1) ij_upper_left(1) = tiles(1)
      if(ij_upper_left(2) > tiles(2)) ij_upper_left(2) = 1

      if(ij_upper_right(1) > tiles(1)) ij_upper_right(1) = 1
      if(ij_upper_right(2) > tiles(2)) ij_upper_right(2) = 1
      if(ij_lower_right(1) > tiles(1)) ij_lower_right(1) = 1
      if(ij_lower_right(2) < 1) ij_lower_right(2) = tiles(2)

    else
      ! set neighbor to 0 -- no neighbor
      if(ij_left(1) < 1) ij_left = 0
      if(ij_right(1) > tiles(1)) ij_right = 0
      if(ij_down(2) < 1) ij_down = 0
      if(ij_up(2) > tiles(2)) ij_up = 0

      if(ij_upper_right(1) > tiles(1)) ij_upper_right(1) = 0
      if(ij_upper_right(2) > tiles(2)) ij_upper_right(2) = 0
      if(ij_lower_right(1) > tiles(1)) ij_lower_right(1) = 0
      if(ij_lower_right(2) < 1) ij_lower_right(2) = 0

      if(ij_lower_left(1) < 1) ij_lower_left(1) = 0
      if(ij_lower_left(2) < 1) ij_lower_left(2) = 0
      if(ij_upper_left(1) < 1) ij_upper_left(1) = 0
      if(ij_upper_left(2) > tiles(2)) ij_upper_left(2) = 0
    endif

    left = tile_ij2n(ij_left)
    right = tile_ij2n(ij_right)
    down = tile_ij2n(ij_down)
    up = tile_ij2n(ij_up)

    lower_left = tile_ij2n(ij_lower_left)
    upper_left = tile_ij2n(ij_upper_left)
    lower_right = tile_ij2n(ij_lower_right)
    upper_right = tile_ij2n(ij_upper_right)

    neighbors = [lower_left, down, lower_right, left, &
                 right, upper_left, up, upper_right]
  endfunction tile_neighbors_2d

  pure function tile_neighbors_3d(is_periodic) result(neighbors)
    ! Returns the neighbor image indices given.
    logical, intent(in) :: is_periodic
    integer(ik) :: neighbors(4)
    integer(ik) :: tiles(2), tiles_ij(2), itile, jtile
    integer(ik) :: left, right, down, up
    integer(ik) :: ij_left(2), ij_right(2), ij_down(2), ij_up(2)
    !
    ! tiles = num_2d_tiles(num_images())
    ! tiles_ij = tile_n2ij(this_image())
    ! itile = tiles_ij(1)
    ! jtile = tiles_ij(2)
    !
    ! ! i, j tile indices for each of the neighbors
    ! ij_left = [itile - 1, jtile]
    ! ij_right = [itile + 1, jtile]
    ! ij_down = [itile, jtile - 1]
    ! ij_up = [itile, jtile + 1]
    !
    ! if (is_periodic) then
    !   ! set neighbor to wrap around the edge
    !   if (ij_left(1) < 1) ij_left(1) = tiles(1)
    !   if (ij_right(1) > tiles(1)) ij_right(1) = 1
    !   if (ij_down(2) < 1) ij_down(2) = tiles(2)
    !   if (ij_up(2) > tiles(2)) ij_up(2) = 1
    ! else
    !   ! set neighbor to 0 -- no neighbor
    !   if (ij_left(1) < 1) ij_left = 0
    !   if (ij_right(1) > tiles(1)) ij_right = 0
    !   if (ij_down(2) < 1) ij_down = 0
    !   if (ij_up(2) > tiles(2)) ij_up = 0
    ! end if
    !
    ! left = tile_ij2n(ij_left)
    ! right = tile_ij2n(ij_right)
    ! down = tile_ij2n(ij_down)
    ! up = tile_ij2n(ij_up)
    !
    ! neighbors = [left, right, down, up]
  endfunction tile_neighbors_3d

  pure function tile_n2ij(n) result(ij)
    ! Given tile index in a 1-d layout, returns the
    ! corresponding tile indices in a 2-d layout.
    !
    !    +---+---+---+
    !  2 | 4 | 5 | 6 |
    !    +---+---+---+
    !  1 | 1 | 2 | 3 |
    !  j +---+---+---+
    !    i 1   2   3
    !
    ! Examples:
    !   * tile_n2ij(2) = [2, 1]
    !   * tile_n2ij(4) = [1, 2]
    !   * tile_n2ij(6) = [3, 2]
    !
    integer(ik), intent(in) :: n
    integer(ik) :: ij(2), i, j, tiles(2)
    if(n == 0) then
      ij = 0
    else
      tiles = num_2d_tiles(num_images())
      j = (n - 1) / tiles(1) + 1
      i = n - (j - 1) * tiles(1)
      ij = [i, j]
    endif
  endfunction tile_n2ij

  pure function tile_ij2n(ij) result(n)
    ! Given tile indices in a 2-d layout, returns the
    ! corresponding tile index in a 1-d layout:
    !
    !    +---+---+---+
    !  2 | 4 | 5 | 6 |
    !    +---+---+---+
    !  1 | 1 | 2 | 3 |
    !  j +---+---+---+
    !    i 1   2   3
    !
    ! Examples:
    !   * tile_ij2n([2, 1]) = 2
    !   * tile_ij2n([1, 2]) = 4
    !   * tile_ij2n([3, 2]) = 6
    !
    integer(ik), intent(in) :: ij(2)
    integer(ik) :: n, tiles(2)
    if(any(ij == 0)) then
      n = 0
    else
      tiles = num_2d_tiles(num_images())
      n = (ij(2) - 1) * tiles(1) + ij(1)
    endif
  endfunction tile_ij2n
endmodule mod_parallel


C$Procedure QDQ2AV (Quaternion and quaternion derivative to a.v.)

      SUBROUTINE QDQ2AV ( Q, DQ, AV )

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

      IMPLICIT NONE

      DOUBLE PRECISION      Q    ( 0 : 3 )
      DOUBLE PRECISION      DQ   ( 0 : 3 )
      DOUBLE PRECISION      AV   ( 3 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     Q          I   Unit SPICE quaternion.
C     DQ         I   Derivative of Q with respect to time.
C     AV         O   Angular velocity defined by Q and DQ.
C
C$ Detailed_Input
C
C     Q              is a unit length 4-vector representing a
C                    SPICE-style quaternion. See the discussion of
C                    quaternion styles in Particulars below.
C
C     DQ             is a 4-vector representing the derivative of
C                    Q with respect to time.
C
C$ Detailed_Output
C
C     AV             is 3-vector representing the angular velocity
C                    defined by Q and DQ, that is, the angular velocity
C                    of the frame defined by the rotation matrix
C                    associated with Q.  This rotation matrix can be
C                    obtained via the SPICELIB routine Q2M; see the
C                    Particulars section for the explicit matrix
C                    entries.
C
C                    AV is the vector (imaginary) part of the
C                    quaternion product
C
C                             *
C                       -2 * Q  * DQ
C
C                    This angular velocity is the same vector that
C                    could be obtained (much less efficiently ) by
C                    mapping Q and DQ to the corresponding C-matrix R
C                    and its derivative DR, then calling the SPICELIB
C                    routine XF2RAV.
C
C                    AV has units of
C
C                       radians / T
C
C                    where
C
C                       1 / T
C
C                    is the unit associated with DQ.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C     1) A unitized version of input quaternion is used in the
C        computation.  No attempt is made to diagnose an invalid
C        input quaternion.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C
C     Quaternion Styles
C     -----------------
C
C     There are different "styles" of quaternions used in
C     science and engineering applications. Quaternion styles
C     are characterized by
C
C        - The order of quaternion elements
C
C        - The quaternion multiplication formula
C
C        - The convention for associating quaternions
C          with rotation matrices
C
C     Two of the commonly used styles are
C
C        - "SPICE"
C
C           > Invented by Sir William Rowan Hamilton
C           > Frequently used in mathematics and physics textbooks
C
C        - "Engineering"
C
C           > Widely used in aerospace engineering applications
C
C
C     SPICELIB subroutine interfaces ALWAYS use SPICE quaternions.
C     Quaternions of any other style must be converted to SPICE
C     quaternions before they are passed to SPICELIB routines.
C
C
C     Relationship between SPICE and Engineering Quaternions
C     ------------------------------------------------------
C
C     Let M be a rotation matrix such that for any vector V,
C
C        M*V
C
C     is the result of rotating V by theta radians in the
C     counterclockwise direction about unit rotation axis vector A.
C     Then the SPICE quaternions representing M are
C
C        (+/-) (  cos(theta/2),
C                 sin(theta/2) A(1),
C                 sin(theta/2) A(2),
C                 sin(theta/2) A(3)  )
C
C     while the engineering quaternions representing M are
C
C        (+/-) ( -sin(theta/2) A(1),
C                -sin(theta/2) A(2),
C                -sin(theta/2) A(3),
C                 cos(theta/2)       )
C
C     For both styles of quaternions, if a quaternion q represents
C     a rotation matrix M, then -q represents M as well.
C
C     Given an engineering quaternion
C
C        QENG   = ( q0,  q1,  q2,  q3 )
C
C     the equivalent SPICE quaternion is
C
C        QSPICE = ( q3, -q0, -q1, -q2 )
C
C
C     Associating SPICE Quaternions with Rotation Matrices
C     ----------------------------------------------------
C
C     Let FROM and TO be two right-handed reference frames, for
C     example, an inertial frame and a spacecraft-fixed frame. Let the
C     symbols
C
C        V    ,   V
C         FROM     TO
C
C     denote, respectively, an arbitrary vector expressed relative to
C     the FROM and TO frames. Let M denote the transformation matrix
C     that transforms vectors from frame FROM to frame TO; then
C
C        V   =  M * V
C         TO         FROM
C
C     where the expression on the right hand side represents left
C     multiplication of the vector by the matrix.
C
C     Then if the unit-length SPICE quaternion q represents M, where
C
C        q = (q0, q1, q2, q3)
C
C     the elements of M are derived from the elements of q as follows:
C
C          +-                                                         -+
C          |           2    2                                          |
C          | 1 - 2*( q2 + q3 )   2*(q1*q2 - q0*q3)   2*(q1*q3 + q0*q2) |
C          |                                                           |
C          |                                                           |
C          |                               2    2                      |
C      M = | 2*(q1*q2 + q0*q3)   1 - 2*( q1 + q3 )   2*(q2*q3 - q0*q1) |
C          |                                                           |
C          |                                                           |
C          |                                                   2    2  |
C          | 2*(q1*q3 - q0*q2)   2*(q2*q3 + q0*q1)   1 - 2*( q1 + q2 ) |
C          |                                                           |
C          +-                                                         -+
C
C     Note that substituting the elements of -q for those of q in the
C     right hand side leaves each element of M unchanged; this shows
C     that if a quaternion q represents a matrix M, then so does the
C     quaternion -q.
C
C     To map the rotation matrix M to a unit quaternion, we start by
C     decomposing the rotation matrix as a sum of symmetric
C     and skew-symmetric parts:
C
C                                        2
C        M = [ I  +  (1-cos(theta)) OMEGA  ] + [ sin(theta) OMEGA ]
C
C                     symmetric                   skew-symmetric
C
C
C     OMEGA is a skew-symmetric matrix of the form
C
C                   +-             -+
C                   |  0   -n3   n2 |
C                   |               |
C         OMEGA  =  |  n3   0   -n1 |
C                   |               |
C                   | -n2   n1   0  |
C                   +-             -+
C
C     The vector N of matrix entries (n1, n2, n3) is the rotation axis
C     of M and theta is M's rotation angle.  Note that N and theta
C     are not unique.
C
C     Let
C
C        C = cos(theta/2)
C        S = sin(theta/2)
C
C     Then the unit quaternions Q corresponding to M are
C
C        Q = +/- ( C, S*n1, S*n2, S*n3 )
C
C     The mappings between quaternions and the corresponding rotations
C     are carried out by the SPICELIB routines
C
C        Q2M {quaternion to matrix}
C        M2Q {matrix to quaternion}
C
C     M2Q always returns a quaternion with scalar part greater than
C     or equal to zero.
C
C
C     SPICE Quaternion Multiplication Formula
C     ---------------------------------------
C
C     Given a SPICE quaternion
C
C        Q = ( q0, q1, q2, q3 )
C
C     corresponding to rotation axis A and angle theta as above, we can
C     represent Q using "scalar + vector" notation as follows:
C
C        s =   q0           = cos(theta/2)
C
C        v = ( q1, q2, q3 ) = sin(theta/2) * A
C
C        Q = s + v
C
C     Let Q1 and Q2 be SPICE quaternions with respective scalar
C     and vector parts s1, s2 and v1, v2:
C
C        Q1 = s1 + v1
C        Q2 = s2 + v2
C
C     We represent the dot product of v1 and v2 by
C
C        <v1, v2>
C
C     and the cross product of v1 and v2 by
C
C        v1 x v2
C
C     Then the SPICE quaternion product is
C
C        Q1*Q2 = s1*s2 - <v1,v2>  + s1*v2 + s2*v1 + (v1 x v2)
C
C     If Q1 and Q2 represent the rotation matrices M1 and M2
C     respectively, then the quaternion product
C
C        Q1*Q2
C
C     represents the matrix product
C
C        M1*M2
C
C
C     About this routine
C     ==================
C
C     Given a time-dependent SPICE quaternion representing the
C     attitude of an object, we can obtain the object's angular
C     velocity AV in terms of the quaternion Q and its derivative
C     with respect to time DQ:
C
C                          *
C        AV  =  Im ( -2 * Q  * DQ )                                  (1)
C
C     That is, AV is the vector (imaginary) part of the product
C     on the right hand side (RHS) of equation (1).  The scalar part
C     of the RHS is zero.
C
C     We'll now provide an explanation of formula (1). For any
C     time-dependent rotation, the associated angular velocity at a
C     given time is a function of the rotation and its derivative at
C     that time. This fact enables us to extend a proof for a limited
C     subset of rotations to *all* rotations:  if we find a formula
C     that, for any rotation in our subset, gives us the angular
C     velocity as a function of the rotation and its derivative, then
C     that formula must be true for all rotations.
C
C     We start out by considering the set of rotation matrices
C
C        R(t) = M(t)C                                                (2)
C
C     where C is a constant rotation matrix and M(t) represents a
C     matrix that "rotates" with constant, unit magnitude angular
C     velocity and that is equal to the identity matrix at t = 0.
C
C     For future reference, we'll consider C to represent a coordinate
C     transformation from frame F1 to frame F2.  We'll call F1 the
C     "base frame" of C.  We'll let AVF2 be the angular velocity of
C     M(t) relative to F2 and AVF1 be the same angular velocity
C     relative to F1.
C
C     Referring to the axis-and-angle decomposition of M(t)
C
C                                                2
C        M(t) = I + sin(t)OMEGA + (1-cos(t))OMEGA                    (3)
C
C     (see the Rotation Required Reading for a derivation) we
C     have
C
C        d(M(t))|
C        -------|     = OMEGA                                        (4)
C          dt   |t=0
C
C     Then the derivative of R(t) at t = 0 is given by
C
C
C        d(R(t))|
C        -------|     = OMEGA  * C                                   (5)
C          dt   |t=0
C
C
C     The rotation axis A associated with OMEGA is defined by        (6)
C
C        A(1) =  - OMEGA(2,3)
C        A(2) =    OMEGA(1,3)
C        A(3) =  - OMEGA(1,2)
C
C     Since the coordinate system rotation M(t) rotates vectors about A
C     through angle t radians at time t, the angular velocity AVF2 of
C     M(t) is actually given by
C
C        AVF2  =  - A                                                (7)
C
C     This angular velocity is represented relative to the image
C     frame F2 associated with the coordinate transformation C.
C
C     Now, let's proceed to the angular velocity formula for
C     quaternions.
C
C     To avoid some verbiage, we'll freely use 3-vectors to represent
C     the corresponding pure imaginary quaternions.
C
C     Letting QR(t), QM(t), and QC be quaternions representing the
C     time-dependent matrices R(t), M(t) and C respectively, where
C     QM(t) is selected to be a differentiable function of t in a
C     neighborhood of t = 0, the quaternion representing R(t) is
C
C        QR(t) = QM(t) * QC                                          (8)
C
C     Differentiating with respect to t, then evaluating derivatives
C     at t = 0, we have
C
C        d(QR(t))|         d(QM(t))|
C        --------|     =   --------|     * QC                        (9)
C           dt   |t=0         dt   |t=0
C
C
C     Since QM(t) represents a rotation having axis A and rotation
C     angle t, then (according to the relationship between SPICE
C     quaternions and rotations set out in the Rotation Required
C     Reading), we see QM(t) must be the quaternion (represented as the
C     sum of scalar and vector parts):
C
C        cos(t/2)  +  sin(t/2) * A                                  (10)
C
C     where A is the rotation axis corresponding to the matrix
C     OMEGA introduced in equation (3).  By inspection
C
C        d(QM(t))|
C        --------|     =   1/2 * A                                  (11)
C           dt   |t=0
C
C     which is a quaternion with scalar part zero.  This allows us to
C     rewrite the quaternion derivative
C
C        d(QR(t))|
C        --------|     =   1/2  *  A  *  QC                         (12)
C           dt   |t=0
C
C     or for short,
C
C        DQ = 1/2 * A * QC                                          (13)
C
C     Since from (7) we know the angular velocity AVF2 of the frame
C     associated with QM(t) is the negative of the rotation axis
C     defined by (3), we have
C
C        DQ = - 1/2 * AVF2 * QC                                     (14)
C
C     Since
C
C        AVF2 = C * AVF1                                            (15)
C
C     we can apply the quaternion transformation formula
C     (from the Rotation Required Reading)
C
C                                 *
C        AVF2 =  QC  *  AVF1  * QC                                  (16)
C
C     Now we re-write (15) as
C
C                                     *
C        DQ = - 1/2 * ( QC * AVF1 * QC ) * QC
C
C           = - 1/2 *   QC * AVF1                                   (17)
C
C     Then the angular velocity vector AVF1 is given by
C
C                       *
C        AVF1  = -2 * QC  * DQ                                      (18)
C
C     The relation (18) has now been demonstrated for quaternions
C     having constant, unit magnitude angular velocity.  But since
C     all time-dependent quaternions having value QC and derivative
C     DQ at a given time t have the same angular velocity at time t,
C     that angular velocity must be AVF1.
C
C$ Examples
C
C     The following test program creates a quaternion and quaternion
C     derivative from a known rotation matrix and angular velocity
C     vector.  The angular velocity is recovered from the quaternion
C     and quaternion derivative by calling QDQ2AV and by an
C     alternate method; the results are displayed for comparison.
C
C              PROGRAM TQDQ2AV
C              IMPLICIT NONE
C        C
C        C     Start with a known rotation and angular velocity.  Find
C        C     the quaternion and quaternion derivative.  The latter is
C        C     computed from
C        C
C        C                       *
C        C        AV  =   -2  * Q  * DQ
C        C
C        C        DQ  =  -1/2 * Q  * AV
C        C
C        C
C        C     SPICELIB Functions
C        C
C              DOUBLE PRECISION      RPD
C
C        C
C        C     Local variables
C        C
C              DOUBLE PRECISION      ANGLE  ( 3 )
C              DOUBLE PRECISION      AV     ( 3 )
C              DOUBLE PRECISION      AVX    ( 3 )
C              DOUBLE PRECISION      DM     ( 3,  3 )
C              DOUBLE PRECISION      DQ     ( 0 : 3 )
C              DOUBLE PRECISION      EXPAV  ( 3 )
C              DOUBLE PRECISION      M      ( 3,  3 )
C              DOUBLE PRECISION      MOUT   ( 3,  3 )
C              DOUBLE PRECISION      Q      ( 0 : 3 )
C              DOUBLE PRECISION      QAV    ( 0 : 3 )
C              DOUBLE PRECISION      XTRANS ( 6,  6 )
C
C              INTEGER               I
C              INTEGER               J
C
C        C
C        C     Pick some Euler angles and form a rotation matrix.
C        C
C              ANGLE(1) = -20.0 * RPD()
C              ANGLE(2) =  50.0 * RPD()
C              ANGLE(3) = -60.0 * RPD()
C
C              CALL EUL2M ( ANGLE(3), ANGLE(2), ANGLE(1), 3, 1, 3, M )
C
C              CALL M2Q   ( M, Q )
C
C        C
C        C     Choose an angular velocity vector.
C        C
C              EXPAV(1) =  1.0D0
C              EXPAV(2) =  2.0D0
C              EXPAV(3) =  3.0D0
C
C        C
C        C     Form the quaternion derivative.
C        C
C              QAV(0)    =  0.D0
C              CALL VEQU ( EXPAV, QAV(1) )
C
C              CALL QXQ ( Q, QAV, DQ )
C
C              CALL VSCLG ( -0.5D0, DQ, 4, DQ )
C
C        C
C        C     Recover angular velocity from Q and DQ using QDQ2AV.
C        C
C              CALL QDQ2AV ( Q, DQ, AV )
C
C        C
C        C     Now we'll obtain the angular velocity from Q and
C        C     DQ by an alternate method.
C        C
C        C     Convert Q back to a rotation matrix.
C        C
C              CALL Q2M ( Q, M )
C
C        C
C        C     Convert Q and DQ to a rotation derivative matrix.  This
C        C     somewhat messy procedure is based on differentiating the
C        C     formula for deriving a rotation from a quaternion, then
C        C     substituting components of Q and DQ into the derivative
C        C     formula.
C        C
C
C              DM(1,1)  =  -4.D0 * (   Q(2)*DQ(2)  +  Q(3)*DQ(3)  )
C
C              DM(1,2)  =   2.D0 * (   Q(1)*DQ(2)  +  Q(2)*DQ(1)
C             .                      - Q(0)*DQ(3)  -  Q(3)*DQ(0)  )
C
C              DM(1,3)  =   2.D0 * (   Q(1)*DQ(3)  +  Q(3)*DQ(1)
C             .                      + Q(0)*DQ(2)  +  Q(2)*DQ(0)  )
C
C              DM(2,1)  =   2.D0 * (   Q(1)*DQ(2)  +  Q(2)*DQ(1)
C             .                      + Q(0)*DQ(3)  +  Q(3)*DQ(0)  )
C
C              DM(2,2)  =  -4.D0 * (   Q(1)*DQ(1)  +  Q(3)*DQ(3)  )
C
C              DM(2,3)  =   2.D0 * (   Q(2)*DQ(3)  +  Q(3)*DQ(2)
C             .                      - Q(0)*DQ(1)  -  Q(1)*DQ(0)  )
C
C              DM(3,1)  =   2.D0 * (   Q(3)*DQ(1)  +  Q(1)*DQ(3)
C             .                      - Q(0)*DQ(2)  -  Q(2)*DQ(0)  )
C
C              DM(3,2)  =   2.D0 * (   Q(2)*DQ(3)  +  Q(3)*DQ(2)
C             .                      + Q(0)*DQ(1)  +  Q(1)*DQ(0)  )
C
C              DM(3,3)  =  -4.D0 * (   Q(1)*DQ(1)  +  Q(2)*DQ(2)  )
C
C        C
C        C     Form the state transformation matrix corresponding to M
C        C     and DM.
C
C              CALL CLEARD ( 36, XTRANS )
C
C        C
C        C     Upper left block:
C        C
C              DO I = 1, 3
C
C                 DO J = 1, 3
C                    XTRANS(I,J) = M(I,J)
C                 END DO
C
C              END DO
C
C
C        C
C        C     Lower right block:
C        C
C              DO I = 1, 3
C
C                 DO J = 1, 3
C                    XTRANS(3+I,3+J) = M(I,J)
C                 END DO
C
C              END DO
C
C        C
C        C     Lower left block:
C        C
C              DO I = 1, 3
C
C                 DO J = 1, 3
C                    XTRANS(3+I,J) = DM(I,J)
C                 END DO
C
C              END DO
C
C        C
C        C     Now use XF2RAV to produce the expected angular velocity.
C        C
C              CALL XF2RAV ( XTRANS, MOUT, AVX )
C
C        C
C        C     The results should match to nearly full double
C        C     precision.
C        C
C              WRITE(*,*) 'Original angular velocity:  ', EXPAV
C              WRITE(*,*) 'QDQ2AV''s angular velocity:  ', AV
C              WRITE(*,*) 'XF2RAV''s angular velocity:  ', AVX
C
C              END
C
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.1, 26-FEB-2008 (NJB)
C
C        Updated header; added information about SPICE
C        quaternion conventions.
C
C-    SPICELIB Version 1.1.0, 31-AUG-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VSCL call.
C
C-    SPICELIB Version 1.0.1, 24-FEB-2004 (NJB)
C
C        Made minor edits to the Particulars header section.
C
C-    SPICELIB Version 1.0.0, 26-AUG-2002 (NJB)
C
C
C-&

C$ Index_Entries
C
C     angular velocity from  quaternion and derivative
C-&

C$ Revisions
C
C-    SPICELIB Version 1.1.0, 31-AUG-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VSCL call.
C
C-&

C
C     Local variables
C
      DOUBLE PRECISION      QHAT  ( 0 : 3 )
      DOUBLE PRECISION      QSTAR ( 0 : 3 )
      DOUBLE PRECISION      QTEMP ( 0 : 3 )

C
C     Get a unitized copy of the input quaternion.
C
      CALL VHATG  ( Q,    4,  QHAT     )

C
C     Get the conjugate QSTAR of QHAT.
C
      QSTAR(0) = QHAT(0)
      CALL VMINUS ( QHAT(1),  QSTAR(1) )

C
C     Compute the angular velocity via the relationship
C
C                       *
C           AV  = -2 * Q  * DQ
C

      CALL QXQ    ( QSTAR,  DQ,        QTEMP )
      CALL VSCL   ( -2.D0,  QTEMP(1),  AV    )

      RETURN
      END


!	Covariances of products of elements of latent vector with normal distribution with covariance matrix cov and mean mean.
function quarticnormal(cov,mean)
implicit none
real(kind=8),intent(in)::cov(:,:),mean(:)
real(kind=8)::quarticnormal(size(mean),size(mean),size(mean),size(mean))
!	Counters
integer::col,col2,row,row2
do row=1,size(mean)
	do col=1,row
		do row2=1,row
			col2=row2
			if(row==row2)col2=col
			quarticnormal(row,col,row2,1:col2)=cov(row,row2)*cov(col,1:col2)+cov(row,1:col2)*cov(row2,col)&
					+mean(row)*mean(row2)*cov(col,1:col2)&
					+mean(col)*mean(row2)*cov(row,1:col2)&
					+mean(row)*mean(1:col2)*cov(col,row2)&
					+mean(col)*mean(1:col2)*cov(row,row2)
			if(row/=row2)quarticnormal(row2,1:col2,row,col)=quarticnormal(row,col,row2,1:col2)

		end do
	end do
end do
return
end function quarticnormal


c=======================================================================
c
c     subroutine KERNELA
c
c     Density Estimation by Non Parametric Gaussian Kernel method
c     with iterative plug-in bandwidth selection. This version only uses
c     the gauss kernel and estimates only the density itself and not its
c     derivatives.
c
c-----------------------------------------------------------------------
      SUBROUTINE kernela ( N, M, X, Z, F, H, info)
c-----------------------------------------------------------------------
c
c     INPUT
c            N      : number of histogram points (n>1)           integer
c            M      : number of gird points      (m>0)           integer
c            X(N)   : sorted returns/histogram (n)                double
c            Z(M)   : sorted output gird (m)                      double
c
c     OUTPUT
c            F(M)   : estimated density (m)                       double
c            H      : estimated iterative plugin bandwitdth       double
c            info   : diagnostic argument                        integer
c
c-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INTEGER info
      DIMENSION X(N),Z(M),F(M)
c
c
      info = 0
      XN=DBLE(N)
      XIQR=X(NINT(.75*XN))-X(NINT(.25*XN)+1)
      PI=3.141592645D0
      RT2PI = DSQRT(2.D0*PI)
      ITER=5
C-------  Estimate inflation constant C
          H2=(.920*XIQR)/(XN**(1.D0/7.D0))
          H3=(.912*XIQR)/(XN**(1.D0/9.D0))
          S2 = 0.D0
          S3 = 0.D0
          DO 20 I = 1, N-1
           DO 30 J = I+1, N
                     D2 = ((X(I) - X(J))/H2)**2
                     D3 = ((X(I) - X(J))/H3)**2
                     IF(D2.GT.50.AND.D3.GT.60) GOTO 20
                     E2 = DEXP(-0.5D0*D2)
                     E3 = DEXP(-0.5D0*D3)
                     S2 = S2 + (D2**2 - 6.D0*D2 + 3.D0)*E2
               S3 = S3 + (D3**3 - 15.D0*D3**2 + 45.D0*D3 - 15.D0)*E3
30          CONTINUE
20         CONTINUE
          RHAT2 = (2.D0*S2)/((XN**2)*(H2**5)*RT2PI)
          RHAT2 = RHAT2 + 3.D0/(RT2PI*XN*(H2**5))
          RHAT3 = (-2.D0*S3)/((XN**2)*(H3**7)*RT2PI)
          RHAT3 = RHAT3 + 15.D0/(RT2PI*XN*(H3**7))
          CO1 = 1.357D0*(RHAT2/RHAT3)**(1.D0/7.D0)
C-
C-------  Compute constant of asymptotic formula
C-
       CONST=1.D0/(2.D0*DSQRT(PI))
       A=1.132795764/RHAT3**(1.D0/7.D0)*XN**(-1.D0/2.D0)
C-
C------  Loop over iterations
C-
       DO 100 IT=1,ITER
C-
C-------  Estimate functional
C
        S=0.D0
        DO 40 I = 1, N-1
           DO 50 J = I+1, N
                     D2 = ((X(I) - X(J))/A)**2
                     IF(D2.GT.50) GOTO 40
                     E2 = DEXP(-0.5D0*D2)
                     S = S + (D2**2 - 6.D0*D2 + 3.D0)*E2
50          CONTINUE
40       CONTINUE
        R2 = (2.D0*S)/((XN**2)*(A**5)*RT2PI)
        R2 = R2 + 3.D0/(RT2PI*XN*(A**5))
C-
C------- Estimate bandwidth by asymptotic formula
C-
         H=(CONST/(R2*XN))**(.2D0)
         A=CO1*H**(5./7.)
100     CONTINUE
C-
C------- Estimate density with plugin bandwidth
C-
      JBEGIN=1
      JEND=1
      DO 200 I=1,M
         S=0.D0
         DO 210 J=JBEGIN,JEND
                T=(Z(I)-X(J))/H
                IF(T.GT.5.0.AND.JBEGIN.LT.N) THEN
                   JBEGIN=JBEGIN+1
                   GOTO 210
                END IF
                S=S+DEXP(-T*T/2.)
210             CONTINUE
         DO 220 JEND=J,N
                T=(Z(I)-X(JEND))/H
                IF(T.LT.-5.0) GOTO 230
                S=S+DEXP(-T*T/2.)
220             CONTINUE
230         F(I)=S/(XN*H*RT2PI)
            JEND=JEND-1
C-
200      CONTINUE
      RETURN
      END


!Segun sea el tipo de la variable, van a ser su definicón de las operaciones aritmeticas.

program aritmeticas
implicit none

integer a, b

real c, d

complex z1, z2

a = 2
b = 1

c = 3.1416
d = 9.81

z1 = cmplx(4, 4)
z2 = cmplx(2, 1)

print *, "Operaciones con enteros:"

print *, "a + b = ", a + b

print *, "a - b = ", a - b

print *, "a * b = ", a * b

print *, "a / b = ", a / b

print *, "a ^ b = ", a ** b

print *, "Operaciones con reales:"

print *, "c + d = ", c + d

print *, "c - d = ", c - d

print *, "c * d = ", c * d

print *, "c / d = ", c / d

print *, "c ^ d = ", c ** d

print *, "Operaciones con complejos:"

print *, "z1 + z2 = ", z1 + z2

print *, "z1 - z2 = ", z1 - z2

print *, "z1 * z2 = ", z1 * z2

print *, "z1 / z2 = ", z1 / z2

print *, "z1 ^ z2 = ", z1 ** z2

end program aritmeticas


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine set_band_velocity_2d(vk_xy)
  use global_variables_2d
  implicit none
  real(8),intent(out) :: vk_xy(2,-NKx:NKx,-NKy:NKy)
  integer :: ikx,iky
  real(8) :: dipx, dipy, mu_y

  select case(nband_type)
  case(N_PARABOLIC_BAND)
!$omp parallel do private(ikx)
    do ikx = -NKx,NKx
      vk_xy(1,ikx,:) = kx(ikx)/mass_r
    end do
!$omp parallel do private(iky)
    do iky = -NKy,NKy
      vk_xy(2,:,iky) = ky(iky)/mass_r
    end do
  case(N_COS_BAND)
    dipx = 2d0*pi/kx_max
    dipy = 2d0*pi/ky_max
!$omp parallel do private(ikx, iky) collapse(2)
    do ikx = -NKx,NKx
      do iky = -NKy,NKy
        vk_xy(1,ikx,iky) = 0.5d0*band_width*dipx*sin(dipx*kx(ikx))*cos(dipy*ky(iky))
        vk_xy(2,ikx,iky) = 0.5d0*band_width*dipy*cos(dipx*kx(ikx))*sin(dipy*ky(iky))
      end do
    end do
  case(N_COS4_BAND)
    dipx = pi/kx_max
    dipy = pi/ky_max
!$omp parallel do private(ikx, iky) collapse(2)
    do ikx = -NKx,NKx
      do iky = -NKy,NKy
        vk_xy(1,ikx,iky) = 4d0*band_width*dipx&
          *cos(dipx*kx(ikx))**3*sin(dipx*kx(ikx))*cos(dipy*ky(iky))**4
        vk_xy(2,ikx,iky) = 4d0*band_width*dipy&
          *cos(dipy*ky(iky))**3*sin(dipy*ky(iky))*cos(dipx*kx(ikx))**4
      end do
    end do
  case(N_HBN_BAND)
    dipx = 2d0*pi/kx_max
    mu_y = 2d0/(dipx**2*band_width)
!$omp parallel do private(ikx, iky) collapse(2)
    do ikx = -NKx,NKx
      do iky = -NKy,NKy
        vk_xy(1,ikx,iky) = dipx*0.5d0*band_width*sin(dipx*kx(ikx))
        vk_xy(2,ikx,iky) = ky(iky)/mu_y
      end do
    end do
  case default
    write(*,"(A,2x,A)")"Invalid nband_type",nband_type
    stop
  end select

end subroutine set_band_velocity_2d


      SUBROUTINE TCNSMT	(IERROR)
C
C LATEST REVISION	 JUNE 1984
C
C PURPOSE		 TO PROVIDE A SIMPLE DEMONSTRATION OF
C			 CONRECSMTH AND	TO TEST	CONRECSMTH ON A	SINGLE
C			 PROBLEM
C
C USAGE			 CALL TCNSMT (IERROR)
C
C ARGUMENTS
C
C ON OUTPUT		 IERROR
C			   AN INTEGER VARIABLE
C			   = 0,	IF THE TEST WAS	SUCCESSFUL,
C			   = 1,	OTHERWISE
C
C I/O			 IF THE	TEST IS	SUCCESSFUL, THE	MESSAGE
C
C			   CONRECSMTH TEST SUCCESSFUL  . . . SEE PLOT TO
C			   VERIFY PERFORMANCE
C
C			 IS PRINTED ON UNIT 6.
C			 IN ADDITION, TWO FRAMES CONTAINING THE	CONTOUR
C			 PLOT ARE PRODUCED ON THE MACHINE GRAPHICS
C			 DEVICE.  IN ORDER TO DETERMINE	IF THE TEST
C			 WAS SUCCESSFUL, IT IS NECESSARY TO EXAMINE
C			 THESE PLOTS.
C
C PRECISION		 SINGLE
C
C
C LANGUAGE		 FORTRAN
C
C ALGORITHM		 THE FUNCTION
C			   Z(X,Y) = X +	Y + 1./((X-.1)**2+Y**2+.09)
C				    -1./((X+.1)**2+Y**2+.09)
C			 FOR X = -1. TO	+1. IN INCREMENTS OF .1	AND
C			     Y = -1.2 TO +1.2 IN INCREMENTS OF .1
C			 IS COMPUTED.
C			 TCNSMT	CALLS SUBROUTINES EZCNTR, CONREC, AND
C			 WTSTR TO DRAW TWO LABELLED CONTOUR PLOTS OF THE
C			 ARRAY Z.
C
C PORTABILITY		 ANSI FORTRAN77	STANDARD
C
C
C Z CONTAINS THE VALUES	TO BE PLOTTED.
C
      REAL	      Z(21,25)
C
C SPECIFY COORDINATES FOR PLOT TITLES.	ON AN ABSTRACT GRID WHERE
C THE INTEGER COORDINATES RANGE	FROM 0.0 TO 1.0, THE VALUES TX AND TY
C DEFINE THE CENTER OF THE TITLE STRING.
C
c      DATA TX/0.42676/,	TY/0.97656/
      TX = 0.42676
      TY = 0.97656
C
C
C INITIALIZE ERROR PARAMETER
C
      IERROR = 0
C
C FILL TWO DIMENSIONAL ARRAY TO	BE PLOTTED
C
      DO  20 I=1,21
	 X = .1*FLOAT(I-11)
	 DO  10	J=1,25
	    Y =	.1*FLOAT(J-13)
	    Z(I,J) = X+Y+1./((X-.10)**2+Y**2+.09)-
     1		     1./((X+.10)**2+Y**2+.09)
   10	 CONTINUE
   20 CONTINUE
C
C SELECT NORMAIZATION TRANS NUMBER TO WRITE TITLES
C
      CALL GSELNT (0)
C
C ENTRY	EZCNTR REQUIRES	ONLY THE ARRAY NAME AND	ITS DIMENSIONS
C
C THE TITLE FOR	THIS PLOT IS
C
C  DEMONSTRATION PLOT FOR EZCNTR ENTRY OF CONRECSMTH
C
      CALL WTSTR (TX,TY,
     1		 'DEMONSTRATION	PLOT FOR EZCNTR	ENTRY OF CONRECSMTH',
     2		 2,0,0)
      CALL EZCNTR (Z,21,25)
C
C
C ENTRY	CONREC ALLOWS USER SPECIFICATION OF PLOT PARAMETERS, IF	DESIRED
C
C IN THIS EXAMPLE, THE LOWEST CONTOUR LEVEL (-4.5), THE	HIGHEST	CONTOUR
C LEVEL	(4.5), AND THE INCREMENT BETWEEN CONTOUR LEVELS	(0.3) ARE
C SPECIFIED.
C
C THE TITLE FOR	THIS PLOT IS
C
C  DEMONSTRATION PLOT FOR CONREC ENTRY OF CONRECSMTH
C
      CALL WTSTR (TX,TY,
     1		 'DEMONSTRATION	PLOT FOR CONREC	ENTRY OF CONRECSMTH',
     2		 2,0,0)
      CALL CONREC (Z,21,21,25,-4.5,4.5,.3,0,0,0)
c     CALL NEWFM
C
c      WRITE (6,1001)
      RETURN
C
c 1001 FORMAT ('	CONRECSMTH TEST	SUCCESSFUL',24X,
c     1	      'SEE PLOT	TO VERIFY PERFORMANCE')
C
C
C---------------------------------------------------------------------
C
C REVISION HISTORY
C
C     JUNE 1984			 CONVERTED TO FORTRAN 77 AND GKS
C
C---------------------------------------------------------------------
      END


program pt
call precisiontest
end program

subroutine precisiontest()

use mpar
real(kind=RSP)   :: real_sp
real(kind=REP) :: real_ep
integer(kind=ISP):: integer_sp
integer(kind=IEP):: integer_ep

WRITE(*,*)
WRITE(*,*) "REAL(KIND=RSP), REAL SINGLE PRECISION"
WRITE(*,*) "RSP =", RSP
WRITE(*,*) "Number of decimal digits of precision =", precision(real_sp)
WRITE(*,*) "Maximum binary exponent =", maxexponent(real_sp)
WRITE(*,*) "Minimim binary exponent =", minexponent(real_sp)
WRITE(*,*)
WRITE(*,*) "REAL(KIND=REP), REAL EXTENDED PRECISION"
WRITE(*,*) "REP =", REP
WRITE(*,*) "Number of decimal digits of precision =", precision(real_ep)
WRITE(*,*) "Maximum binary exponent =", maxexponent(real_ep)
WRITE(*,*) "Minimim binary exponent =", minexponent(real_ep)
WRITE(*,*)
WRITE(*,*) "INTEGER(KIND=ISP), INTEGER SINGLE PRECISION"
WRITE(*,*) "ISP =", ISP
WRITE(*,*) "Range =", range(integer_sp)
WRITE(*,*)
WRITE(*,*) "INTEGER(KIND=IEP), INTEGER EXTENDED PRECISION"
WRITE(*,*) "IEP =", IEP
WRITE(*,*) "Range =", range(integer_ep)
WRITE(*,*)

end subroutine precisiontest


program demo_rnum0
use M_calculator, only : rnum0
implicit none
real :: x, y, z
   x=rnum0('20/3.4')
   y=rnum0('CI = 10 * sin(3.1416/4)')
   z=rnum0('CI')
   write(*,*)x,y,z
end program demo_rnum0


!
! ej6_b.f90
!
! Copyright 2016 Bruno S <bruno@oac.unc.edu.ar>
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 2 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program; if not, write to the Free Software
! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
! MA 02110-1301, USA.
!
!
!
PROGRAM ej5_b

use precision, pr => dp

IMPLICIT NONE

integer :: i, j, k, n
real(pr) :: x, y, h, x0, xf, y0, error, exacta
real(pr) :: f1, f2, start_time, finish_time

open(unit=10, file='ej5_b.dat', status='UNKNOWN', action='WRITE')

write(10, *) "#  x    y   exacta   err"

x0 = 0._pr
xf = 1._pr

!condiciones iniciales
y0 = 1._pr

n = 10000

h = (xf - x0)/real(n, pr)

! para t == 0
y = y0
x = x0

exacta = exp(-x*x*0.5_pr)
write(10, *) x, y, exacta, 0._pr

call cpu_time(start_time)
do i = 1, n
    ! integro en v
    f1 = h * f(x, y)
    f2 = h * f(x + h, y + f1)
    y = y + (f1 + f2) * 0.5_pr

    x = x0 + h * i  ! ya que f no depende de t
    exacta = exp(-x*x*0.5_pr)
    error = abs(y - exacta)
    write(10, *)  x, y, exacta, error
end do
call cpu_time(finish_time)

CONTAINS

function f(x, y)
real (pr) :: f
real (pr), intent(in) :: x, y

    f = -y*x

end function f

END PROGRAM ej5_b


!----------------------------------------------------------------------
! "dimless.f"
!----------------------------------------------------------------------
SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)
      DOUBLE PRECISION V, N, v1, vca, vL, vK, v2, v4, gca, gL, gK, phin
      DOUBLE PRECISION  minf, v3, ninf, C, psi

      V = U(1)
      N = U(2)
! bifurcation parameters
      v1 = PAR(1)
	  v3 = PAR(2)
! model parameters
      vca = 80.d0;
      vL = (-70.d0/vca);
      vK = (-90.d0/vca);
      v2 = (25.d0/vca);
	  !v3 = (-11.d0/vca);
      v4 = (14.5d0/vca);
	  gK = 3.1416E-13;
      gca = (1.57E-13/gk);
      gL = ((7.854E-14)/gk);
	  C = 1.9635E-14;
      phin = 2.664d0;
	  psi=((C*phin)/gk)
!model equations and auxiliary functions
      minf = (0.5d0*(1+tanh((V-v1)/v2)));
      ninf = 0.5d0*(1+tanh((V-v3)/v4));
      F(1) = -(gL*(V-vL)+N*(V-vK)+gca*minf*(V-1.d0));
      F(2) = psi*cosh((V-v3)/(2.d0*v4))*(ninf-N);
      END SUBROUTINE FUNC
      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T
    ! initial values for the bifurcation parameters
      PAR(1)=-0.5d0
	  PAR(2)=-0.1375
    ! initial conditions
      U(1)=-0.18484d0
      U(2)=0.37227d0
      END SUBROUTINE STPNT
      SUBROUTINE BCND
      END SUBROUTINE BCND
      SUBROUTINE ICND
      END SUBROUTINE ICND
      SUBROUTINE FOPT
      END SUBROUTINE FOPT
      SUBROUTINE PVLS
      END SUBROUTINE PVLS


       subroutine zone_setup(nx, nxmax, ny, nz)

       include 'header.h'
       include 'mpi_stuff.h'

       integer nx(*), nxmax(*), ny(*), nz(*)

       integer           i,  j, zone_no
       integer           id_west, id_east, jd_south, jd_north
       double precision  x_r, y_r, x_smallest, y_smallest

       if (dabs(ratio-1.d0) .gt. 1.d-10) then

c        compute zone stretching only if the prescribed zone size ratio
c        is substantially larger than unity

         x_r   = dexp(dlog(ratio)/(x_zones-1))
         y_r   = dexp(dlog(ratio)/(y_zones-1))
         x_smallest = dble(gx_size)*(x_r-1.d0)/(x_r**x_zones-1.d0)
         y_smallest = dble(gy_size)*(y_r-1.d0)/(y_r**y_zones-1.d0)

c        compute tops of intervals, using a slightly tricked rounding
c        to make sure that the intervals are increasing monotonically
c        in size

         do i = 1, x_zones
            x_end(i) = x_smallest*(x_r**i-1.d0)/(x_r-1.d0)+0.45d0
         end do

         do j = 1, y_zones
            y_end(j) = y_smallest*(y_r**j-1.d0)/(y_r-1.d0)+0.45d0
         end do

       else

c        compute essentially equal sized zone dimensions

         do i = 1, x_zones
           x_end(i)   = (i*gx_size)/x_zones
         end do

         do j = 1, y_zones
           y_end(j)   = (j*gy_size)/y_zones
         end do

       endif

       x_start(1) = 1
       do i = 1, x_zones
          if (i .ne. x_zones) x_start(i+1) = x_end(i) + 1
          x_size(i)  = x_end(i) - x_start(i) + 1
       end do

       y_start(1) = 1
       do j = 1, y_zones
          if (j .ne. y_zones) y_start(j+1) = y_end(j) + 1
          y_size(j) = y_end(j) - y_start(j) + 1
       end do

       if (npb_verbose .gt. 1 .and. myid .eq. root) then
          write (*,98)
       endif
 98    format(/' Zone sizes:')

       do j = 1, y_zones
         do i = 1, x_zones
           zone_no = (i-1)+(j-1)*x_zones+1
           nx(zone_no) = x_size(i)
           nxmax(zone_no) = nx(zone_no) + 1 - mod(nx(zone_no),2)
           ny(zone_no) = y_size(j)
           nz(zone_no) = gz_size

           id_west  = mod(i-2+x_zones,x_zones)
           id_east  = mod(i,          x_zones)
           jd_south = mod(j-2+y_zones,y_zones)
           jd_north = mod(j,          y_zones)
           iz_west (zone_no) = id_west +  (j-1)*x_zones + 1
           iz_east (zone_no) = id_east +  (j-1)*x_zones + 1
           iz_south(zone_no) = (i-1) + jd_south*x_zones + 1
           iz_north(zone_no) = (i-1) + jd_north*x_zones + 1

           if (npb_verbose .gt. 1 .and. myid .eq. root) then
             write (*,99) zone_no, nx(zone_no), ny(zone_no),
     $                    nz(zone_no)
           endif
         end do
       end do

 99    format(i5,':  ',i5,' x',i5,' x',i5)

       return
       end

       subroutine zone_starts(num_zones, nx, nxmax, ny, nz,
     &                        start1, start5,
     $                        qstart_west,  qstart_east,
     $                        qstart_south, qstart_north)

       include 'header.h'
       include 'mpi_stuff.h'

       integer   num_zones
       integer   nx(*), nxmax(*), ny(*), nz(*)
       dimension start1(*), start5(*), qstart_west(*),
     $           qstart_east(*), qstart_south(*), qstart_north(*)

       integer   zone, zone_size, iz, ip, zone2, ig, id, itmp
       integer   x_face_size, y_face_size
       integer   ip_west, ip_east, ip_south, ip_north

       do iz = 1, proc_num_zones
         zone = proc_zone_id(iz)
         zone_size = nxmax(zone)*ny(zone)*nz(zone)
         if (iz .eq. 1) then
           start1(iz) = 1
           start5(iz) = 1
         endif
         if (iz .ne. proc_num_zones) then
           start1(iz+1) = start1(iz) + zone_size
           start5(iz+1) = start5(iz) + zone_size*5
         else
           if (start1(iz)+zone_size-1 .gt. proc_max_size) then
             write(*,50) zone,proc_max_size,start1(iz)+zone_size-1
             call mpi_abort(MPI_COMM_WORLD, ierror)
             stop
           endif
         endif
   50    format(' Error in size: zone',i5,' proc_max_size',i10,
     &          ' access_size',i10)
       enddo

c ...  for 'qbc_in'
       qoffset = 1
       do 10 ip = 0, num_procs-1

         if (ip .eq. myid) goto 10

         do 15 zone = 1, num_zones
           x_face_size = (ny(zone)-2)*(nz(zone)-2)*5
           y_face_size = (nx(zone)-2)*(nz(zone)-2)*5

           zone2 = iz_west(zone)
           ip_east  = zone_proc_id(zone)
           if (ip_east .eq. ip .and. zone_proc_id(zone2) .lt. 0) then
             qstart2_east(zone2) = qoffset
             qoffset = qoffset + x_face_size
           endif

           zone2 = iz_east(zone)
           ip_west  = zone_proc_id(zone)
           if (ip_west .eq. ip .and. zone_proc_id(zone2) .lt. 0) then
             qstart2_west(zone2) = qoffset
             qoffset = qoffset + x_face_size
           endif

           zone2 = iz_south(zone)
           ip_north = zone_proc_id(zone)
           if (ip_north .eq. ip .and. zone_proc_id(zone2) .lt. 0) then
             qstart2_north(zone2) = qoffset
             qoffset = qoffset + y_face_size
           endif

           zone2 = iz_north(zone)
           ip_south = zone_proc_id(zone)
           if (ip_south .eq. ip .and. zone_proc_id(zone2) .lt. 0) then
             qstart2_south(zone2) = qoffset
             qoffset = qoffset + y_face_size
           endif
   15    continue

   10  continue

c ...  for 'qbc_out'
       qoffset = 1
       do 20 ip = 0, num_procs-1

         if (ip .eq. myid) goto 25

         do 30 zone = 1, num_zones
           if (zone_proc_id(zone) .ge. 0) goto 30

           x_face_size = (ny(zone)-2)*(nz(zone)-2)*5
           y_face_size = (nx(zone)-2)*(nz(zone)-2)*5

           ip_west  = zone_proc_id(iz_west(zone))
           if (ip_west .eq. ip) then
             qstart_west(zone) = qoffset
             qoffset = qoffset + x_face_size
           endif

           ip_east  = zone_proc_id(iz_east(zone))
           if (ip_east .eq. ip) then
             qstart_east(zone) = qoffset
             qoffset = qoffset + x_face_size
           endif

           ip_south = zone_proc_id(iz_south(zone))
           if (ip_south .eq. ip) then
             qstart_south(zone) = qoffset
             qoffset = qoffset + y_face_size
           endif

           ip_north = zone_proc_id(iz_north(zone))
           if (ip_north .eq. ip) then
             qstart_north(zone) = qoffset
             qoffset = qoffset + y_face_size
           endif
   30    continue

   25    qcomm_size(ip+1) = qoffset - 1
   20  continue

c ...  for intra-process zone copy
       do 40 zone = 1, num_zones
         if (zone_proc_id(zone) .ge. 0) goto 40

         ip_west  = zone_proc_id(iz_west(zone))
         ip_east  = zone_proc_id(iz_east(zone))
         ip_south = zone_proc_id(iz_south(zone))
         ip_north = zone_proc_id(iz_north(zone))

         x_face_size = (ny(zone)-2)*(nz(zone)-2)*5
         y_face_size = (nx(zone)-2)*(nz(zone)-2)*5

         if (ip_west  .lt. 0) then
           qstart_west(zone)  = qoffset
           qoffset = qoffset + x_face_size
         endif
         if (ip_east  .lt. 0) then
           qstart_east(zone)  = qoffset
           qoffset = qoffset + x_face_size
         endif
         if (ip_south .lt. 0) then
           qstart_south(zone) = qoffset
           qoffset = qoffset + y_face_size
         endif
         if (ip_north .lt. 0) then
           qstart_north(zone) = qoffset
           qoffset = qoffset + y_face_size
         endif
   40  continue

c ...  set up cyclic communication group
       iz = 1
       do while (iz .lt. myid)
         iz = iz * 2
       enddo
       if (iz .gt. myid) iz = iz / 2

       do ig = 1, num_procs
         pcomm_group(ig) = ig - 1
       enddo
       do ig = num_procs+1, num_procs2
         pcomm_group(ig) = -1
       enddo

       id = 0
       do while (iz .ge. 1)
         if (id+iz .gt. myid) goto 45
         do ig = 1, num_procs, iz*2
           do ip = ig, ig+iz-1
              itmp = pcomm_group(ip)
              pcomm_group(ip) = pcomm_group(ip+iz)
              pcomm_group(ip+iz) = itmp
           enddo
         enddo
         id = id + iz
   45    iz = iz/2
       enddo

       ip = 1
       do ig = 1, num_procs
         do while (pcomm_group(ip) .lt. 0)
           ip = ip + 1
         enddo
         pcomm_group(ig) = pcomm_group(ip)
         ip = ip + 1
       enddo

       if (npb_verbose .gt. 1) then
         do iz = 1, proc_num_zones
           zone = proc_zone_id(iz)
           write(*,60) myid, iz, zone, start1(iz), start5(iz)
         enddo
         write(*,70) myid, qoffset-1
   60    format(' myid',i5,' iz=',i5,' zone=',i5,
     &          ' start1=',i10,' start5=',i10)
   70    format(' myid',i5,' qcomm_size=',i10)

         do ig = 1, num_procs
           ip = pcomm_group(ig) + 1
           if (ip .eq. 1) then
             qoffset = qcomm_size(ip)
           else
             qoffset = qcomm_size(ip) - qcomm_size(ip-1)
           endif
           write(*,80) myid, ip-1, qoffset, qcomm_size(ip)
         enddo
   80    format(' myid',i5,' proc',i5,' qcomm_size',2(1x,i10))
       endif

       return
       end


    program generate_bathymetry
    implicit none

    integer, parameter :: im = 500
    integer, parameter :: jm = 90
    integer :: i,j
    real(8) :: dx,dy,x,y,h0,h02,tht,cs,sn,pi,  &
               ytmp,xp,yp,ctmp1,ctmp2,depth(im,jm)
    character(len=80) :: test_case

    pi = 2.*acos(0.)

    test_case = 'landslide'

    if(trim(test_case)=='submerged_bar') then
      dx = 0.02
      do j = 1,jm
      do i = 1,im
        x = (i-1)*dx
        if(x<=6.0) then
          depth(i,j) = 0.4
        elseif(x>6.0.and.x<=12.0) then
          depth(i,j) = 0.4-(x-6.0)/20.0
        elseif(x>12.0.and.x<=14.0) then
          depth(i,j) = 0.1
        elseif(x>14.0.and.x<17.0) then
          depth(i,j) = 0.4-(17.0-x)/10.0
        else
          depth(i,j) = 0.4
        endif
      enddo
      enddo
    elseif(trim(test_case)=='landslide') then
      dx = 0.02
      do j = 1,jm
      do i = 1,im
        x = (i-1)*dx+0.5*dx
        if(x<=1.5/tan(15.*pi/180.)+0.1) then
          depth(i,j) = (x-0.1)*tan(15.*pi/180.)
        else
          depth(i,j) = 1.5
        endif
      enddo
      enddo
    elseif(trim(test_case)=='breaking_solitary_wave') then
      dx = 0.02
      do j = 1,jm
      do i = 1,im
        x = (i-1)*dx
        if(x<=4.0) then
          depth(i,j) = 0.21
        else
          depth(i,j) = 0.21-(x-4.0)/20.
        endif
      enddo
      enddo
    elseif(trim(test_case)=='dam_break') then
      dx = 0.05
      do j = 1,jm
      do i = 1,im
        x = (i-1)*dx
        if(x<=25.5) then
          depth(i,j) = 0.01
        elseif(x>25.5.and.x<=28.5) then
          depth(i,j) = -(x-25.5)*0.4/3.0
        elseif(x>28.5.and.x<=31.5) then
          depth(i,j) = -(31.5-x)*0.4/3.0
        elseif(x>31.5) then
          depth(i,j) = 0.01
        endif
      enddo
      enddo
    elseif(trim(test_case)=='tidal_wave') then
      dx = 7.5
      do j = 1,jm
      do i = 1,im
        x = (i-1)*dx
        if(abs(x-750)<=187.5) then
          depth(i,j) = 8.0
        else
          depth(i,j) = 16.0
        endif
      enddo
      enddo
    elseif(trim(test_case)=='Berkhoff_Shoal') then
      dx = 0.025
      dy = 0.05
      h0 = .45
      h02 = 0.07
      tht = 70.*3.14159/180
      cs    = cos(tht)
      sn    = sin(tht)
      ytmp  = 5.84-(h0-h02)/.02
      do i = 1, im
      do j = 1, jm
        x  = float(i-1)*dx- 12.0
        y  = float(j-1)*dy- 10.0
        xp =  x*cs+y*sn
        yp = -x*sn+y*cs
        ctmp1 = (xp/4.)**2+(yp/3.)**2
        ctmp2 = (xp/5.)**2+(yp/3.75)**2
        if(yp.ge.5.84) then
          depth(i,j) = h0
        elseif (yp.le.ytmp) then
          depth(i,j) = h02
        elseif (ctmp1.gt.1.) then
          depth(i,j) = h0-0.02*(5.84-yp)
        else
          depth(i,j) = .75-.02*(5.84-yp)-0.5*sqrt(1.-ctmp2)
        endif
      enddo
      enddo
    endif

    open(11,file='depth.txt')
    do j = 1,jm
      write(11,'(5000f8.4)') (depth(i,j),i=1,im)
    enddo
    close(11)

    end


! spectral.f90  -  Rayleigh iteration solver for eigenvalue problem

program spectral
  use integrator
  use utils
  implicit none

  integer, parameter :: n = 150
  real, parameter :: ell = 1.0
  real, parameter :: pi = 3.1415926535897932384626433832795028842Q0
  real, dimension(n) :: x, theta, psi
  real, dimension (n,n) :: L, H
  real :: lambda
  real :: lambdas(n)

  ! Initialize spectral operators
  call init_grid()
  call init_l()

  print *
  print "(a)", "Q4. Spectral-based eigenvalues (harmonic potential)"
  call find_eigenvalues()
  print "(f19.12)", lambdas(1:10)
  call plot_wavefunctions("q4", lambdas(1:10))

  V => V_anharmonic
  print *
  print "(a)", "Q5. Spectral-based eigenvalues (anharmonic potential)"
  call find_eigenvalues()
  print "(f19.12)", lambdas(1:10)
  call plot_wavefunctions("q5", lambdas(1:10))

contains

  subroutine find_eigenvalues()
    ! TODO properly encapsulate local variables
    integer :: i

    ! Hamiltonian in static Schrödinger equation
    H = -L/2.0
    do i = 1, n
      H(i,i) = -L(i,i)/2.0 + V(x(i))
    end do

    psi = 1.0 / (1.0 + x*x)

    ! Relax using Rayleigh's iteration
    do i = 1,64
      lambda = dot_product(psi,matmul(H,psi))/dot_product(psi,psi)
      psi = lsolve(psi,lambda)
      psi = psi/sqrt(dot_product(psi,psi))
    end do

    lambdas = real_eigenvalues(H)
    call partial_sort(lambdas)
  end subroutine

  ! initialize the collocation grid
  subroutine init_grid()
    integer i

    forall (i=1:n) theta(i) = pi*(n-i+0.5)/n
    x = ell/tan(theta)
  end subroutine

  ! evaluate rational Chebyshev basis on a grid theta
  subroutine evalb(n, pts, theta, Tn, Tnx, Tnxx)
    integer n, pts
    real, dimension(pts), intent(in) :: theta
    real, dimension(pts), intent(out), optional :: Tn, Tnx, Tnxx

    ! Chebyshev basis and its derivatives
    if (present(Tn))   Tn = cos(n*theta)
    if (present(Tnx))  Tnx = n * sin(n*theta) * sin(theta)**2/ell
    if (present(Tnxx)) Tnxx = -n * sin(theta)**3 * &
      (n*cos(n*theta)*sin(theta) + 2.0*sin(n*theta)*cos(theta)) / ell**2
  end subroutine evalb

  ! initialize linear spectral derivative operator
  subroutine init_l()
    integer :: i, pivot(n), status
    real :: A(n,n), B(n,n), Tn(n), Tnxx(n)

    ! evaluate basis and differential operator values on collocation grid
    do i = 1,n
      call evalb(i-1, n, theta, Tn=Tn, Tnxx=Tnxx)
      A(i, :) = Tn
      B(i, :) = Tnxx
    end do

    ! find linear operator matrix
    status = 0; select case (kind(A))
    case(4); call sgesv(n, n, A, n, pivot, B, n, status)
    case(8); call dgesv(n, n, A, n, pivot, B, n, status)
    case default; call abort
    end select

    ! bail at first sign of trouble
    if (status /= 0) call abort

    L = transpose(B)
  end subroutine

  ! Rayleigh's iteration solving eigenvalue problem:
  ! [-1/2 d^2/dx^2 + V(x)] psi(x) = lambda psi(x)
  function lsolve(psi, lambda)
    real lambda, psi(n), lsolve(n), A(n,n), B(n)
    integer i, pivot(n), status

    ! linear improvement inflating eigenvector
    A = H
    forall (i=1:n) A(i,i) = H(i,i) - lambda
    B = psi

    ! find linear operator matrix
    status = 0; select case (kind(A))
    case(4); call sgesv(n, 1, A, n, pivot, B, n, status)
    case(8); call dgesv(n, 1, A, n, pivot, B, n, status)
    case default; call abort
    end select

    ! bail at first sign of trouble
    if (status /= 0) call abort

    lsolve = B
  end function

end program


c     cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine ricbes(nn,y,bj,bn,dj,dn)
c     ================================================================
c
c     computes spherical bessel functions j and n and its derivatives
c
      implicit   none
c
c
      integer    nn,l,k,i,nm
c
      real*8     flm,fll
c
      complex*16 a,aj,x,y
      complex*16 as,ac,xinv,x2
c
      complex*16 bj(nn),bn(nn),dj(nn),dn(nn)
c
c
      x=y
c
      if (abs(x).eq.0.0d0) then
         write(*,*) ' x equals to zero'
         call fstop('ricbes')
      endif
c
      as = sin(x)
      ac = cos(x)
      bj(1) = as
      dj(1) = ac
      dn(1) = exp((0.d0,1.d0)*x)
      bn(1) = (0.d0,-1.d0)*dn(1)
      if(nn.eq.1) return
      xinv = 1.d0/x
c Forward recursion for small L
1     k=(int(0.75*(abs(dreal(x))+abs(dimag(x))))+2)/4+1
      if(k.gt.1) then
	 if (k.gt.nn) k=nn
	 bj(2)=bj(1)*xinv-ac
	 do l = 3, k
           flm = l+l-3
	   bj(l) = flm*bj(l-1)*xinv-bj(l-2)
	 enddo
      endif

      if(k.lt.nn) then
c Backward recursion from very large L down to L=k
        a=bj(k)
        nm=nn*4
        aj=2*nm+1
        x2=x*x
        do l = nm, nn+2, -1
	   aj=(2*l-1)-x2/aj
        enddo
        bj(nn)=(2*nn+1)*aj*xinv-x
        bj(nn-1)=(2*nn-1)*bj(nn)*xinv-aj
        do l = nn-1, k+1, -1
	   bj(l-1)=(2*l-1)*bj(l)*xinv-bj(l+1)
        enddo
c scale to give correct bj(k)
        aj=a/bj(k)
        do l = k+1, nn
	   bj(l)=aj*bj(l)
        enddo
        bj(k)=a
      endif

c Find bn using forward recursion
      bn(2) = bn(1)*xinv -  dn(1)
      dj(2) = bj(1)-bj(2)*xinv
      dn(2) = bn(1)-bn(2)*xinv
c
c     ================================================================
c     recursion relations
c     ================================================================
      do l=3,nn
         flm = l+l-3
         bn(l) = flm*bn(l-1)*xinv-bn(l-2)
         fll = l-1
         dj(l) = bj(l-1)-fll*bj(l)*xinv
         dn(l) = bn(l-1)-fll*bn(l)*xinv
      enddo
c
      return
      end


      real function psolR(solD,v,w,x,y)
c
c     + + + PURPOSE + + +
c     Computes potential solar radiation on a sloping surface, in cal/cm2/day
c
c     Called from sunmap.
c     Author(s):
c     Reference: Swift, 1976 "Algorithm for solar radiation on Mountain slopes"
c
c     Date recoded: 11/07/2006.
c     Recoded by: S. Dun
c
c     + + + KEYWORDS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
      real solD,v,w,x,y
c
c     + + + ARGUMENT DEFINITIONS + + +
c     solD   - declination of sun
c     v - time offset in hour angle between actual annd equivalent slope
c     w - lattitude of eqivalent slope
c
c     + + + PARAMETERS + + +
c
c     + + + COMMON BLOCKS + + +
c
c
c     + + + LOCAL DEFINITIONS + + +
c
c     + + + FUNCTION DECLARATIONS + + +

c     + + + END SPECIFICATIONS + + +
c
      psolR = (sin(solD) * sin(w) * (x - y) *12.0 / 3.141593)
     1   + (cos(solD) * cos(w) * (sin(x + v) - sin(y + v))
     2   * 12. / 3.141593)
c
      return
      end


!     Example 4.1 in Xue 2000
!
!     The tiled code by Xue and by Pips give the same correct results,
!     but they are different.

      program tiling07

      real A(-2:9,-1:6)

      do 100 i = -2, 9
         do j = -1, 6
            a(i,j) = 10*(i+2)+j+1
         enddo
 100  continue

      do i = 1, 9
         do j = 1, 5
            a(i,j) = a(i,j-2)+a(i-3,j+1)
         enddo
      enddo

      print *, a(5,2), a(6,3)

!     Reinitialize A

      do i = -2, 9
         do j = -1, 6
            a(i,j) = 10*(i+2)+j+1
         enddo
      enddo

!     Use tiled code from Xue

      do it = 0, 2
         do jt = max(it-1,0), (it+4)/2
            do i = 3*it+1, 3*it+3
               do j = max(-it+2*jt+1,1), min((-it+6*jt+9)/3,5)
                  a(i,j) = a(i,j-2)+a(i-3,j+1)
               enddo
            enddo
         enddo
      enddo

      print *, a(5,2), a(6,3)

      end


!! how does Fortran handle NaN vis-a-vis max and min
!! https://groups.google.com/forum/#!topic/comp.lang.fortran/MwVfrvUowHU

use, intrinsic :: ieee_arithmetic
use, intrinsic :: iso_fortran_env, stderr=>error_unit
implicit none

real :: A(4), x, y, nan, inf

nan = ieee_value(0., ieee_quiet_nan)
inf = ieee_value(0., ieee_positive_inf)

if(.not.ieee_is_nan(nan)) then
  write(stderr,*) 'NaN: ',nan
  error stop 'NaN not working correctly'
endif

A = [0., 1., 2., nan]
print *, 'maximum of ',A, 'is', maxval(A)
if(maxval(A) /= 2) error stop 'maxval() not working with NaN'

x = nan
y = 1.

print *, 'maximum of',x,'and',y,'is',max(x,y)
if (max(x,y) /= 1) error stop 'max() not working with NaN'

! Gfortran, Flang 7 say inf; PGI, Intel say NaN
print *,'max of inf() and NaN is', max(inf, nan)

end program


       PARAMETER (NSTEP=20)
       DIMENSION PHI(0:NSTEP)

       H=1./NSTEP

100    PRINT *, ' Enter step size ( .eq. 0 to stop)'
       READ *, DT
       IF (DT .EQ. 0.) STOP
       DTH=DT/H**2

       DO 10 IX=0,NSTEP
          X=IX*H
          PHI(IX)=X*(1.-X)
 10    CONTINUE
       CALL NORM(PHI,NSTEP)

       DO 20 ITER=1,100
          POLD=0.
          DO 30 IX=1,NSTEP-1
             PNEW=PHI(IX)+DTH*(POLD+PHI(IX+1)-2*PHI(IX))
             POLD=PHI(IX)
             PHI(IX)=PNEW
30        CONTINUE
          CALL NORM(PHI,NSTEP)

          IF (MOD(ITER,4) .EQ. 0) THEN
            E=0.
            DO 50 IX=1,NSTEP
               E=E+(PHI(IX)-PHI(IX-1))**2
50          CONTINUE
            E=E/(H)
            PRINT *,' iteration = ', ITER, '  energy = ', E
          END IF
20     CONTINUE
       GOTO 100
       END

       SUBROUTINE NORM(PHI,NSTEP)
       DIMENSION PHI(0:NSTEP)

       XNORM=0.
       DO 10 IX=0,NSTEP
          XNORM=XNORM+PHI(IX)**2
10     CONTINUE
       XNORM=SQRT(NSTEP/XNORM)
       DO 20 IX=0,NSTEP
          PHI(IX)=PHI(IX)*XNORM
20     CONTINUE
       RETURN
       END


module polynomial_module

use globalvars_module
implicit none

contains

!========================================================
subroutine polyinitialize(pl,n,coeffarray)

	      integer :: n
	      real*8 :: coeffarray(:)
	      integer :: i

	      type(polynomial) :: pl

	      pl%n=n
	      allocate(pl%coeffs(n+1))

	      do i=1,n+1
	      	pl%coeffs(i)=coeffarray(i)
	      enddo

end subroutine
!========================================================
subroutine zeropolyinitialize(pl,n)

		integer,intent(in) :: n
		type(polynomial) :: pl

		integer :: i
		real*8,allocatable :: coeffarray(:)

		allocate(coeffarray(n+1))

		do  i=1,n+1
			coeffarray(i)=0.d0
		enddo

		call polyinitialize(pl,n,coeffarray)

end subroutine zeropolyinitialize
!========================================================
subroutine polymultiply(p1,p2,pout)

		type(polynomial), intent(in) :: p1,p2
		type(polynomial), intent(out) :: pout
		integer :: i,j

		call zeropolyinitialize(pout,p1%n+p2%n)

		do i=1,p1%n+1
		do j=1,p2%n+1
			pout%coeffs(i+j-1)=pout%coeffs(i+j-1)&
					+p1%coeffs(i)*p2%coeffs(j)
		enddo
		enddo

end subroutine polymultiply
!========================================================
subroutine polyderivative(pin,pout)

	type(polynomial),intent(in) :: pin
	type(polynomial),intent(out) :: pout

	integer :: i

	pout%n=pin%n-1
	allocate(pout%coeffs(pout%n+1))

	do i=1,pout%n+1
		pout%coeffs(i)=pin%coeffs(i+1)*i
		!print *,"coeff of ",i,":",pout%coeffs(i)
	enddo

end subroutine polyderivative
!========================================================
subroutine printpoly(pl)

		type(polynomial) :: pl
		integer :: i

		print *,"order of pl:",pl%n

		do i=1,pl%n
			write(*,'(F4.2,A,I2,A)',advance='no')pl%coeffs(i),"x^",(i-1),"+"
		enddo
		write(*,'(F8.2,A,I2)')pl%coeffs(i),"x^",(i-1)

end subroutine printpoly
!========================================================
subroutine createlagrangepoly(x,np,polyarray)

	integer :: i,j,np
	real*8 :: x(np)
	real*8 :: dnmtr
	type(polynomial) :: polyarray(np)

	real*8 :: initcoeff(1)
	real*8 :: termcoeff(2)
	real*8,allocatable :: lagrcoeffs(:)
	type(polynomial) :: term
	type(polynomial) :: temp
	type(polynomial) :: current

	call zeropolyinitialize(term,1)

	do i=1,np

		dnmtr=1.d0
		do j=1,np
			if(j .ne. i) then
			dnmtr=dnmtr*(x(i)-x(j))
			endif
		enddo

		call zeropolyinitialize(polyarray(i),0)
		polyarray(i)%coeffs(1)=1.d0/dnmtr
		do j=1,np

			if(j .ne. i) then

				term%coeffs(1)=-x(j)
				term%coeffs(2)=1.d0
				call polymultiply(polyarray(i),term,temp)

				polyarray(i)=temp
			endif
		enddo

		print *,"order of polyarray",i,"is",polyarray(i)%n

	enddo

end subroutine createlagrangepoly
!========================================================
function polyfindval(pl,x) result(total)

	      real*8 :: x,total,pdt
	      type(polynomial) :: pl
	      integer :: i

	      total=0.0
	      pdt=1.0

	      do i=1,pl%n+1

	      	total=total+pl%coeffs(i)*pdt
		pdt=pdt*x

	      enddo

end function
!========================================================
function polyfindderval(pl,x) result(total)

	      real*8 :: x,total,pdt
	      type(polynomial) :: pl
	      type(polynomial) :: plder
	      integer :: i

	      call polyderivative(pl,plder)
	      total=0.0
	      pdt=1.0

	      do i=1,plder%n+1

	      	total=total+plder%coeffs(i)*pdt
		pdt=pdt*x

	      enddo

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

end module polynomial_module


      EXTERNAL FEX
      DOUBLE PRECISION ATOL, RTOL, RWORK, T, TOUT, Y
      DIMENSION Y(4), RWORK(100), IWORK(100)
      NEQ = 4
      Y(1) = 1.
      Y(2) = 0.
      Y(3) = 0.
      Y(4) = 0.
      T = 0.
      TOUT = 10.
      ITOL = 1
      RTOL = 1.D-6
      ATOL = 1.D-6
      ITASK = 1
      ISTATE = 1
      IOPT = 0
      LRW = 100
      LIW = 100
      JT = 2
      DO I = 1,100000
         CALL DLSODA(FEX,NEQ,Y,T,TOUT,ITOL,RTOL,ATOL,ITASK,ISTATE,
     *        IOPT,RWORK,LRW,IWORK,LIW,JDUM,JT)
         TOUT = TOUT + 1.
      END DO
      WRITE(*,*) "T,Y:", T,Y(1),Y(2),Y(3),Y(4)
      END

      SUBROUTINE FEX (NEQ, T, Y, YDOT)
      DOUBLE PRECISION T, Y, YDOT, GL, AL, DTH
      DIMENSION Y(4), YDOT(4)
      GL = -4.905
      AL = 1.25
C      WRITE(*,*)T,Y(1),Y(3)
      DTH = Y(3) - Y(1)
      YDOT(1) = Y(2)
      YDOT(2) = GL * sin(Y(1)) + AL / 2 * DTH
      YDOT(3) = Y(4)
      YDOT(4) = GL * sin(Y(3)) - AL * DTH
      RETURN
      END

c$$$Local Variables:
c$$$compile-command: "make -k pendulum"
c$$$End: