CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      PROGRAM EXMPL7
C     Example 7: The time-dependent Schroedinger Equation
C  COMPUTATIONAL PHYSICS (FORTRAN VERSION)
C  by Steven E. Koonin and Dawn C. Meredith
C  Copyright 1989, Addison-Wesley Publishing Company, Inc.
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      CALL INIT           !display header screen, setup parameters
5     CONTINUE            !main loop/ execute once for each set of param
        CALL PARAM        !get input from screen
        CALL ARCHON       !calculate time evolution of a wavepacket
      GOTO 5
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE ARCHON
C calculates the time evolution of a one-dimensional wavepacket
C according to the time-dependent Schroedinger equation
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'PARAM.E7'
      INCLUDE 'IO.ALL'
C Local variables:
      COMPLEX PHI(0:MAXLAT)      !wavepacket
      REAL PHI2(0:MAXLAT)        !wavepacket squared
      REAL TIME                  !time
      REAL TPROB,LPROB,RPROB     !normalization of the wavepacket
      REAL LX,RX,TX              !average position
      REAL E                     !energy
      REAL DT                    !time step
      INTEGER IT                 !time index
      REAL DTSCAL                !scaled time step
      REAL DTMIN,DTMAX           !min,max reasonable size for DTSCAL
      INTEGER NLINES             !number of lines printed to terminal
      INTEGER SCREEN             !send to terminal
      INTEGER PAPER              !make a hardcopy
      INTEGER FILE               !send to a file
      INTEGER NSTEP              !number of time steps to take
      LOGICAL MORE,NEWDT         !options for continuing
      INTEGER FRAME              !which frame of the movie is it?
      INTEGER NFREQ              !graphing frequency (movies only)
      REAL DIFF                  !temp variables for movies
C Functions:
      REAL GETFLT                !get floating point number from screen
      INTEGER YESNO              !get yes/no answer from screen
      LOGICAL LOGCVT             !change from 1,0 to true and false
      INTEGER GETINT             !get integer data from screen
      DATA SCREEN,PAPER,FILE/1,2,3/
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     output summary of parameters
      IF (TTERM) CALL PRMOUT(OUNIT,NLINES)
      IF (TFILE) CALL PRMOUT(TUNIT,NLINES)
      IF (GFILE) CALL PRMOUT(GUNIT,NLINES)
C
      CALL INTPHI(PHI,PHI2)     !setup initial PHI array
      TIME=0.                   !initialize time
C
      NSTEP=40                  !def num of time steps until next prompt
      NFREQ=10                  !def graphing freq (movies only)
      DTSCAL=.2                 !def scaled time step
      DTMAX=100.                !max scaled time step
      DTMIN=DX**2*K0**2/25.     !minimum scaled time step
C
10    CONTINUE                  !loop over different DT and/or NSTEP
        DTSCAL=GETFLT(DTSCAL,-DTMAX,DTMAX,
     +      'Enter time step (units of K0**-2)')
        IF (ABS(DTSCAL) .LT. DTMIN)
     +      DTSCAL=SIGN(DTMIN,DTSCAL)    !don't let it get too small
        DT=DTSCAL/K0**2                  !physical time
        NSTEP=GETINT(NSTEP,1,1000,'Enter number of time steps')
        NLINES=NLINES+4
C
        IF (MOVIES) THEN
           NFREQ=GETINT(NFREQ,1,1000,'Enter graphing frequency')
           !make sure that total num of frames is divisible by 4
           DIFF=MOD(NSTEP,4*NFREQ)
           IF (DIFF .NE. 0) NSTEP=NSTEP+4*NFREQ-DIFF
        END IF
C
        CALL TRDIAG(DT)          !calculate GAMMA for this DT
        IF (TFILE) CALL TITLES(TUNIT,NLINES,DT)
C
15      CONTINUE                 !loop over sets of NSTEP time steps
          IF (TTERM) CALL TITLES(OUNIT,NLINES,DT)
C
          DO 20 IT=1,NSTEP       !time evolution
             TIME=TIME+DT
             CALL EVOLVE(PHI,PHI2,DT)  !take a time step
             CALL NORMLZ(PHI2,LPROB,RPROB,TPROB,LX,RX,TX) !calc norm
             CALL ENERGY(PHI,PHI2,E)   !calc energy
             !output
             IF ((MOVIES) .AND. (MOD(IT,NFREQ) .EQ. 0)) THEN
                FRAME=MOD(IT/NFREQ,4)
                IF (FRAME .EQ. 1) THEN
                    CALL GRFOUT(SCREEN,PHI2,TIME,TPROB,TX,E)
                ELSE
                    CALL GRFSEC(SCREEN,PHI2,TIME,TPROB,TX,FRAME)
                END IF
             END IF
             IF (TTERM) CALL
     +        TXTOUT(OUNIT,E,TIME,LPROB,RPROB,TPROB,LX,RX,TX,NLINES)
             IF (TFILE) CALL
     +        TXTOUT(TUNIT,E,TIME,LPROB,RPROB,TPROB,LX,RX,TX,NLINES)
20        CONTINUE
C
C         graphics output
          IF (MOVIES) THEN
             CALL TMODE          !switch back to text mode
          ELSE IF (GTERM) THEN
C            print out graphics now if text was being sent to screen
             CALL PAUSE('to see the wave packet ...',1)
             CALL GRFOUT(SCREEN,PHI2,TIME,TPROB,TX,E)
          END IF
          IF (GFILE) CALL GRFOUT(FILE,PHI2,TIME,TPROB,TX,E)
          IF (GHRDCP) CALL GRFOUT(PAPER,PHI2,TIME,TPROB,TX,E)
C
          MORE=LOGCVT(YESNO(1,'Continue iterating?'))
        IF (MORE) THEN
            NLINES=0
            IF (TTERM) CALL CLEAR
            GOTO 15
        END IF
C
        NEWDT=LOGCVT(YESNO(1,'Change time step and continue?'))
      IF (NEWDT) THEN
        NLINES=0
        IF (TTERM) CALL CLEAR
        GOTO 10
      END IF
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE EVOLVE(PHI,PHI2,DT)
C take one time step using the implicit algorithm
C (Eq. 7.30-7.33 and 7.11-7.16)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'PARAM.E7'
C Input/output variables:
      COMPLEX PHI(0:MAXLAT)      !wavepacket (I/O)
      REAL PHI2(0:MAXLAT)        !wavepacket squared (I/O)
      REAL DT                    !time step (input)
C Local variables:
      COMPLEX CONST              !term in matrix inversion
      COMPLEX CHI                !part of wave function
      COMPLEX BETA(0:MAXLAT)     !term in matrix inversion
      INTEGER IX                 !lattice index
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      CONST=4*SQRTM1*DX*DX/DT
      BETA(NPTS-1)=0.            !initial conditions for BETA
      DO 10 IX=NPTS-2,0,-1       !backward recursion for BETA
         BETA(IX)=GAMMA(IX+1)*(BETA(IX+1)-CONST*PHI(IX+1))
10    CONTINUE
C
      CHI=(0.,0.)                !boundary conditions
      DO 20 IX=1,NPTS-1          !forward recursion for CHI and PHI
         CHI=GAMMA(IX)*CHI+BETA(IX-1)  !CHI at this lattice point
         PHI(IX)=CHI-PHI(IX)           !PHI at new time
         PHI2(IX)=ABS(PHI(IX))**2      !PHI2 at new time
20    CONTINUE
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE TRDIAG(DT)
C calculate GAMMA for the inversion of the tridiagonal matrix
C (Eq. 7.30-7.33 and 7.11-7.16)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'PARAM.E7'
C Input variables:
      REAL DT                          !time step
C Local variables:
      INTEGER IX                       !lattice index
      COMPLEX AZERO,CONST1             !terms in matrix inversion
      REAL CONST2                      !useful constant
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      CONST1=-2.+2*SQRTM1*DX**2/DT
      CONST2=DX*DX*K0*K0
      GAMMA(NPTS)=0.                   !initial conditions for GAMMA
      DO 20 IX=NPTS-1,0,-1             !backward recursion
         AZERO=CONST1-CONST2*V(IX)     !use GAMMA(IX)=ALPHA(IX-1)
         GAMMA(IX)=-1./(AZERO+GAMMA(IX+1))
20    CONTINUE
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE NORMLZ(PHI2,LPROB,RPROB,TPROB,LX,RX,TX)
C given PHI2, finds left, right, and total probability of the wavepacket
C as well as the average X value (left, right, and total)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'PARAM.E7'
C Input variable:
      REAL PHI2(0:MAXLAT)       !wavepacket squared
C Output variables:
      REAL LPROB,RPROB,TPROB    !left, right, and total probability
      REAL LX,RX,TX             !left, right, and total average position
C Local variables:
      INTEGER IX                !lattice index
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      LPROB=0.                           !zero sums
      LX=0.
      DO 10 IX=1,IMID-1                  !integrate with trapezoidal rule
         LPROB=LPROB+PHI2(IX)
         LX=LX+X(IX)*PHI2(IX)
10    CONTINUE
      LPROB=LPROB+PHI2(IMID)/2           !middle point is shared between
      LX=LX+XMID*PHI2(IMID)/2            !  left and right
C
      RPROB=PHI2(IMID)/2                 !middle point contribution
      RX=XMID*PHI2(IMID)/2
      DO 20 IX=IMID+1,NPTS-1             !integrate with trapezoidal rule
         RPROB=RPROB+PHI2(IX)
         RX=RX+X(IX)*PHI2(IX)
20    CONTINUE
C
      TPROB=LPROB+RPROB                  !total probability
      IF (LPROB .NE. 0.) LX=LX/LPROB     !normalize LX,RX
      IF (RPROB .NE. 0.) RX=RX/RPROB
      TX=LX*LPROB+RX*RPROB               !total <x> is a weighted sum
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE ENERGY(PHI,PHI2,E)
C calculate the scaled energy E (units of K0**2) given PHI and PHI2
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'PARAM.E7'
C Input/Output variables:
      COMPLEX PHI(0:MAXLAT)      !wavepacket (input)
      REAL PHI2(0:MAXLAT)        !wavepacket squared (input)
      REAL E                     !total scaled energy (output)
C Local variables:
      INTEGER IX                 !lattice index
      REAL PE                    !potential energy
      COMPLEX KE                 !kinetic energy
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      PE=0.                      !initialize sums
      KE=0.
      DO 10 IX=1,NPTS-1          !integrate using trapezoidal rule
         PE=PE+V(IX)*PHI2(IX)
         KE=KE+CONJG(PHI(IX))*(PHI(IX-1)-2*PHI(IX)+PHI(IX+1))
10    CONTINUE
      KE=-KE/DX**2/K0**2
      E=PE+REAL(KE)              !energy scale = K0**2
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE INTPHI(PHI,PHI2)
C creates initial PHI array from input parameters
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'PARAM.E7'
C Output variables:
      COMPLEX PHI(0:MAXLAT)        !wavepacket
      REAL PHI2(0:MAXLAT)          !wavepacket squared
C Local variables:
      INTEGER IX                   !lattice index
      REAL NORM,LPROB,RPROB,SQRTN  !normalization of the wavepacket
      REAL LX,RX,TX                !average position
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IF (PACKET .EQ. LORNTZ) THEN         !Lorentzian
         DO 10 IX=1,NPTS-1
            PHI(IX)=CEXP(SQRTM1*K0*X(IX))/(SIGMA**2+(X(IX)-W0)**2)
            PHI2(IX)=CABS(PHI(IX))**2
10       CONTINUE
C
      ELSE IF (PACKET .EQ. GAUSS) THEN     !Gaussian
         DO 20 IX=1,NPTS-1
            PHI(IX)=CEXP(SQRTM1*K0*X(IX))*EXP(-(X(IX)-W0)**2/2/SIGMA**2)
            PHI2(IX)=CABS(PHI(IX))**2
20       CONTINUE
      END IF
C
      PHI(0)=0.             !potential is infinite at ends of lattice
      PHI(NPTS)=0.          ! so PHI is zero there
C
      CALL NORMLZ(PHI2,LPROB,RPROB,NORM,LX,RX,TX) !normalize wavepacket
      SQRTN=SQRT(NORM)
      DO 30 IX=0,NPTS
         PHI(IX)=PHI(IX)/SQRTN
         PHI2(IX)=PHI2(IX)/NORM
30    CONTINUE
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE INIT
C initializes constants, displays header screen,
C initializes menu arrays for input parameters
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'IO.ALL'
      INCLUDE 'MENU.ALL'
      INCLUDE 'PARAM.E7'
C Local parameters:
      CHARACTER*80 DESCRP          !program description
      DIMENSION DESCRP(20)
      INTEGER NHEAD,NTEXT,NGRAPH   !number of lines for each description
      REAL EPS                     !small number to set width of potntls
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     get environment parameters
      CALL SETUP
C
C     display header screen
      DESCRP(1)= 'EXAMPLE 7'
      DESCRP(2)= 'Solution of time-dependent Schroedinger Equation'
      DESCRP(3)= 'for a wavepacket in a one-dimensional potential'
      NHEAD=3
C
C     text output description
      DESCRP(4)= 'time, energy, probability, and <x>'
      NTEXT=1
C
C     graphics output description
      DESCRP(5)= 'potential and |wavepacket|**2 vs. x'
      NGRAPH=1
C
      CALL HEADER(DESCRP,NHEAD,NTEXT,NGRAPH)
C
C     define constants
      PI=4.0*ATAN(1.0)
      SQRTM1=(0,1)              !square root of -1
C
C     if you change VXMIN and/or VXMAX, change prompts below
C     for X0, W0, and CYCLE=K0*(VXMAX-VXMIN)/2/PI
      VXMIN=-1.                 !physical limits on lattice
      VXMAX=1.
C
      EPS=1./20.                !find constants so that at X=X0+A
      AGAUSS=LOG(1./EPS)        ! or X=XO-A, V(X)=EPS*V0
      ASTEP=TAN(PI*(1./2.-EPS)) !(doesn't apply to parabola)
C
C     setup menu arrays, beginning with constant part
      CALL MENU
C
      MTYPE(13)=TITLE
      MPRMPT(13)='POTENTIAL FUNCTION MENU'
      MLOLIM(13)=2.
      MHILIM(13)=1.
C
      MTYPE(14)=MTITLE
      MPRMPT(14)=
     +'1) Square-well: V=V0 for X0-A < X < X0+A'
      MLOLIM(14)=0.
      MHILIM(14)=0.
C
      MTYPE(15)=MTITLE
      MPRMPT(15)=
     +'2) Gaussian: V(X)=V0*(EXP-(AGAUSS*((X-X0)/A)**2))'
      MLOLIM(15)=0.
      MHILIM(15)=0.
C
      MTYPE(16)=MTITLE
      MPRMPT(16)=
     +'3) Parabolic: V(X)=V0*(X-X0)**2/A**2'
      MLOLIM(16)=0.
      MHILIM(16)=0.
C
      MTYPE(17)=MTITLE
      MPRMPT(17)=
     +'4) Smooth step: V(X)=V0*(2/PI*ATN(ASTEP*(X-X0)/A)+1)/2'
      MLOLIM(17)=0.
      MHILIM(17)=1.
C
      MTYPE(18)=MCHOIC
      MPRMPT(18)='Make a menu choice and press return'
      MTAG(18)='19 19 19 19'
      MLOLIM(18)=1.
      MHILIM(18)=4.
      MINTS(18)=1
      MREALS(18)=1.
C
      MTYPE(19)=FLOAT
      MPRMPT(19)='Enter X0 (center of potential  -1 < X0 < 1 )'
      MTAG(19)='Center of potential (X0)'
      MLOLIM(19)=VXMIN
      MHILIM(19)=VXMAX
      MREALS(19)=VXMIN+3*(VXMAX-VXMIN)/4
C
      MTYPE(20)=FLOAT
      MPRMPT(20)='Enter A (half width of one-twentieth max)'
      MTAG(20)='Half-width of potential (A)'
      MLOLIM(20)=10*(VXMAX-VXMIN)/MAXLAT
      MHILIM(20)=(VXMAX-VXMIN)*10.
      MREALS(20)=(VXMAX-VXMIN)/25.
C
      MTYPE(21)=FLOAT
      MPRMPT(21)='Enter V0 (height of potential in units of K0**2)'
      MTAG(21)='Height of potential V0 (units of K0**2)'
      MLOLIM(21)=-100.
      MHILIM(21)=100.
      MREALS(21)=.3
C
      MTYPE(22)=FLOAT
      MPRMPT(22)=
     + 'Enter XMID which separates right from left (-1 < XMID < 1)'
      MTAG(22)='middle X value'
      MLOLIM(22)=VXMIN
      MHILIM(22)=VXMAX
      MREALS(22)=VXMIN+3*(VXMAX-VXMIN)/4
C
      MTYPE(23)=TITLE
      MPRMPT(23)='WAVEPACKET MENU'
      MLOLIM(23)=2.
      MHILIM(23)=1.
C
      MTYPE(24)=MTITLE
      MPRMPT(24)=
     +'1) Lorentzian:  PHI(X)=EXP(I*K0*X)/(SIGMA**2+(X-W0)**2)'
      MLOLIM(24)=0.
      MHILIM(24)=0.
C
      MTYPE(25)=MTITLE
      MPRMPT(25)=
     +'2) Gaussian: PHI(X)=EXP(I*K0*X)*EXP(-(X-W0)**2/2/SIGMA**2)'
      MLOLIM(25)=0.
      MHILIM(25)=1.
C
      MTYPE(26)=MCHOIC
      MPRMPT(26)='Make a menu choice and press return'
      MTAG(26)='27 27'
      MLOLIM(26)=1.
      MHILIM(26)=2.
      MINTS(26)=2
      MREALS(26)=2.
C
      MTYPE(27)=FLOAT
      MPRMPT(27)='Enter W0 (center of packet -1 < W0 < 1 )'
      MTAG(27)='Center of packet (W0)'
      MLOLIM(27)=VXMIN
      MHILIM(27)=VXMAX
      MREALS(27)=VXMIN+(VXMAX-VXMIN)/3
C
      MTYPE(28)=FLOAT
      MPRMPT(28)='Enter SIGMA (width of packet)'
      MTAG(28)='Width of packet (SIGMA)'
      MLOLIM(28)=10*(VXMAX-VXMIN)/MAXLAT
      MHILIM(28)=10*(VXMAX-VXMIN)
      MREALS(28)=.125*(VXMAX-VXMIN)
C
      MTYPE(29)=FLOAT
      MPRMPT(29)='Enter number of cycles on lattice = K0/PI '
      MTAG(29)='Number of cycles = K0/PI'
      MLOLIM(29)=-REAL(MAXLAT)/4.
      MHILIM(29)= REAL(MAXLAT)/4.
      MREALS(29)= 10.
C
      MTYPE(30)=SKIP
      MREALS(30)=35.
C
      MTYPE(38)=NUM
      MPRMPT(38)= 'Enter number of lattice points'
      MTAG(38)= 'Number of lattice points'
      MLOLIM(38)=20.
      MHILIM(38)=MAXLAT
      MINTS(38)=200
C
      MTYPE(39)=SKIP
      MREALS(39)=60.
C
      MSTRNG(MINTS(75))= 'exmpl7.txt'
C
      MTYPE(76)=SKIP
      MREALS(76)=80.
C
      MSTRNG(MINTS(86))= 'exmpl7.grf'
C
      MTYPE(87)=SKIP
      MREALS(87)=90.
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE PARAM
C gets parameters from screen
C ends program on request
C closes old files
C maps menu variables to program variables
C opens new files
C calculates all derivative parameters
C performs checks on parameters
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'MENU.ALL'
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.E7'
C Local variables:
      REAL CYCLES             !number of cycles on lattice
      REAL MAXCYC             !maximum number of cycles for given NPTS
C     map between menu items and parameters
      INTEGER IPOT,IX0,IA,IV0,IXMID,IPACK,ISIGMA,IW0,ICYCLE,INPTS
      PARAMETER (IPOT   = 18)
      PARAMETER (IX0    = 19)
      PARAMETER (IA     = 20)
      PARAMETER (IV0    = 21)
      PARAMETER (IXMID  = 22)
      PARAMETER (IPACK  = 26)
      PARAMETER (IW0    = 27)
      PARAMETER (ISIGMA = 28)
      PARAMETER (ICYCLE = 29)
      PARAMETER (INPTS  = 38)
C Functions:
      LOGICAL LOGCVT          !converts 1 and 0 to true and false
      REAL GETFLT             !get floating point number from screen
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     get input from terminal
      CALL CLEAR
      CALL ASK(1,ISTOP)
C
C     stop program if requested
      IF (MREALS(IMAIN) .EQ. STOP) CALL FINISH
C
C     close files if necessary
      IF (TNAME .NE. MSTRNG(MINTS(ITNAME)))
     +     CALL FLCLOS(TNAME,TUNIT)
      IF (GNAME .NE. MSTRNG(MINTS(IGNAME)))
     +     CALL FLCLOS(GNAME,GUNIT)
C
C     set new parameter values
C     physical and numerical
      POT=MINTS(IPOT)
      X0=MREALS(IX0)
      A=MREALS(IA)
      V0=MREALS(IV0)
      XMID=MREALS(IXMID)
      PACKET=MINTS(IPACK)
      SIGMA=MREALS(ISIGMA)
      W0=MREALS(IW0)
      CYCLES=MREALS(ICYCLE)
      NPTS=MINTS(INPTS)
C
C     text output
      TTERM=LOGCVT(MINTS(ITTERM))
      TFILE=LOGCVT(MINTS(ITFILE))
      TNAME=MSTRNG(MINTS(ITNAME))
C
C     graphics output
      GTERM=LOGCVT(MINTS(IGTERM))
      GHRDCP=LOGCVT(MINTS(IGHRD))
      GFILE=LOGCVT(MINTS(IGFILE))
      GNAME=MSTRNG(MINTS(IGNAME))
C
C     open files
      IF (TFILE) CALL FLOPEN(TNAME,TUNIT)
      IF (GFILE) CALL FLOPEN(GNAME,GUNIT)
      !files may have been renamed
      MSTRNG(MINTS(ITNAME))=TNAME
      MSTRNG(MINTS(IGNAME))=GNAME
C
C     derivative parameters
      MOVIES=.FALSE.
      IF ((GTERM) .AND. (.NOT. TTERM)) MOVIES=.TRUE.
      DX=(VXMAX-VXMIN)/NPTS            !spatial step
      IMID=NINT((XMID-VXMIN)/DX)       !nearest lattice index to XMID
      XMID=VXMIN+IMID*DX               !force XMID to be a lattice point
      MREALS(IXMID)=XMID               !change default accordingly
C
C     check CYCLES with respect to lattice size
      MAXCYC=REAL(NPTS)/4.             !max number of cycles for NPTS
      IF (CYCLES .GT. MAXCYC) THEN
         WRITE (OUNIT,*) 'Number of cycles is too large for NPTS'
         CYCLES=GETFLT(MAXCYC/10.,-MAXCYC,MAXCYC,
     +      'Enter number of cycles = K0/PI')
         MREALS(ICYCLE)=CYCLES
      END IF
      K0=CYCLES*2*PI/(VXMAX-VXMIN)
      CALL CLEAR
C
      CALL POTNTL                     !setup potential array
      IF ((GTERM) .OR. (GHRDCP)) CALL GRFINT !initialize graphing param
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE POTNTL
C fills the potential array
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'PARAM.E7'
C Local variables:
      INTEGER IX               !lattice index
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      DO 5 IX=0,NPTS           !array of X values
         X(IX)=VXMIN+IX*DX
5     CONTINUE
C
      IF (POT .EQ. SQUARE) THEN       !Square bump/well
         DO 10 IX=0,NPTS
            IF ((X(IX) .GE. (X0-A)) .AND. (X(IX) .LE. (X0+A))) THEN
               V(IX)=V0
            ELSE
               V(IX)=0.
            END IF
10       CONTINUE
C
C     AGAUSS is fixed so that V(X0+A)=V(XO-A)=EPS*V0 (see INIT)
      ELSE IF (POT .EQ. GAUSS) THEN   !Gaussian bump/well
         DO 20 IX=0,NPTS
            V(IX)=V0*EXP(-AGAUSS*(X(IX)-X0)**2/A**2)
20       CONTINUE
C
      ELSE IF (POT .EQ. PARAB) THEN   !Parabola
         DO 30 IX=0,NPTS
            V(IX)=V0*((X(IX)-X0)**2/A**2)
30       CONTINUE
C
C     ASTEP is fixed so that V(X0+A)=1.-EPS*V0 and
C                            V(XO-A)=EPS*V0 (see INIT)
      ELSE IF (POT .EQ. STEP) THEN    !Smooth step function
         DO 40 IX=0,NPTS
            V(IX)=V0/2*(2/PI*ATAN(ASTEP*(X(IX)-X0)/A)+1.)
40       CONTINUE
      END IF
C
      VMAX=V(0)                          !find VMAX and VMIN to give
      VMIN=V(0)                          !   a scale for graphics
      DO 50 IX=1,NPTS
         IF (V(IX) .GT. VMAX) VMAX=V(IX)
         IF (V(IX) .LT. VMIN) VMIN=V(IX)
50    CONTINUE
      IF (VMAX .EQ. VMIN) VMAX=VMIN+1    !need a nonzero difference
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
       SUBROUTINE PRMOUT(MUNIT,NLINES)
C outputs parameter summary to MUNIT
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
       INCLUDE 'IO.ALL'
       INCLUDE 'PARAM.E7'
C Passed variables:
       INTEGER MUNIT            !unit number for output (input)
       INTEGER NLINES           !number of lines written so far (output)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
       IF (MUNIT .EQ. OUNIT) CALL CLEAR
C
       WRITE (MUNIT,2)
       WRITE (MUNIT,4)
       WRITE (MUNIT,24) XMID,NPTS,DX
       WRITE (MUNIT,2)
       IF (POT .EQ. SQUARE) THEN
         WRITE (MUNIT,6)
       ELSE IF (POT .EQ. GAUSS) THEN
         WRITE (MUNIT,8)
       ELSE IF (POT .EQ. PARAB) THEN
         WRITE (MUNIT,10)
       ELSE IF (POT .EQ. STEP) THEN
         WRITE (MUNIT,12)
       END IF
       WRITE (MUNIT,14) X0,A,V0
       WRITE (MUNIT,2)
       IF (PACKET .EQ. LORNTZ) THEN
         WRITE (MUNIT,16)
       ELSE IF (PACKET .EQ. GAUSS) THEN
         WRITE (MUNIT,18)
       END IF
       WRITE (MUNIT,20) W0,SIGMA
       WRITE (MUNIT,22) K0,K0**2
       WRITE (MUNIT,2)
C
       NLINES=11
C
2      FORMAT (' ')
4      FORMAT
     + (' Output from example 7: Time-dependent Schroedinger Equation')
6      FORMAT (' Square-barrier/well: V=V0 for X0-A < X < X0+A')
8      FORMAT
     + (' Gaussian barrier/well: V(X)=V0*(EXP-(AGAUSS*((X-X0)/A)**2))')
10     FORMAT (' Parabolic well: V(X)=V0*(X-X0)**2/A**2')
12     FORMAT (' Smooth step: V(X)=V0*(2/PI*ATN(ASTEP*(X-X0)/A)+1)/2')
14     FORMAT (' X0 = ',1PE12.5,5X,' A = ',1PE12.5,5X,
     +         ' V0 (units K0**2) = ',1PE12.5)
16     FORMAT (' Lorentzian wavepacket:  ',
     +         'PHI(X)=EXP(I*K0*X)/(SIGMA**2+(X-W0)**2)')
18     FORMAT (' Gaussian wavepacket: ',
     +         'PHI(X)=EXP(I*K0*X)*EXP(-(X-W0)**2/2/SIGMA**2)')
20     FORMAT (' W0 = ',1PE12.5,5X,' SIGMA = ',1PE12.5)
22     FORMAT (' K0 = ',1PE12.5,5X,' K0**2 (energy scale) = ',1PE12.5)
24     FORMAT (' XMIDDLE = ',1PE12.5,5X,' NPTS = ',I5,5X,
     +         ' space step = ',1PE12.5)
26     FORMAT (18X,'energy',9X,'probability',19X,'<x>')
28     FORMAT (7X,'time',7X,'K0**2 ',5X,'left',3X,'right',3X,'total',6X,
     +         'left',4X,'right',4X,'total')
30     FORMAT (7X,'----',7X,'------',5X,'----',3X,'-----',3X,'-----',6X,
     +         '----',4X,'-----',4X,'-----')
C
       RETURN
       END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
       SUBROUTINE TITLES(MUNIT,NLINES,DT)
C write out time step and column titles to MUNIT
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
       INCLUDE 'IO.ALL'
C Passed variables:
       INTEGER MUNIT            !unit number for output (input)
       INTEGER NLINES           !number of lines written so far (output)
       REAL DT                  !time step (input)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
       WRITE (MUNIT,*)  ' '
       WRITE (MUNIT,20) DT
       WRITE (MUNIT,26)
       WRITE (MUNIT,28)
       WRITE (MUNIT,30)
C
       IF (MUNIT .EQ. OUNIT) NLINES=NLINES+5
C
20     FORMAT (' time step = ',1PE15.8)
26     FORMAT (18X,'energy',9X,'probability',19X,'<x>')
28     FORMAT (7X,'time',7X,'K0**2 ',5X,'left',3X,'right',3X,'total',6X,
     +         'left',4X,'right',4X,'total')
30     FORMAT (7X,'----',7X,'------',5X,'----',3X,'-----',3X,'-----',6X,
     +         '----',4X,'-----',4X,'-----')
C
       RETURN
       END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE TXTOUT(MUNIT,E,TIME,LPROB,RPROB,TPROB,LX,RX,TX,NLINES)
C writes results for one state to MUNIT
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'IO.ALL'
C Input variables:
      INTEGER MUNIT                !output unit specifier
      REAL TIME                    !time
      REAL TPROB,LPROB,RPROB       !normalization of the wavepacket
      REAL LX,RX,TX                !average position
      REAL E                       !energy
      INTEGER NLINES               !number of lines printed so far (I/O)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     if screen is full, clear screen and retype headings
      IF ((MOD(NLINES,TRMLIN-4) .EQ. 0)
     +                          .AND. (MUNIT .EQ. OUNIT)) THEN
         CALL PAUSE('to continue...',1)
         CALL CLEAR
         WRITE (MUNIT,26)
         WRITE (MUNIT,28)
         WRITE (MUNIT,30)
         NLINES=NLINES+3
      END IF
C
      WRITE (MUNIT,40) TIME,E,LPROB,RPROB,TPROB,LX,RX,TX
C     keep track of printed lines only for terminal output
      IF (MUNIT .EQ. OUNIT) NLINES=NLINES+1
C
26     FORMAT (18X,'energy',9X,'probability',19X,'<x>')
28     FORMAT (7X,'time',7X,'K0**2 ',5X,'left',3X,'right',3X,'total',6X,
     +         'left',4X,'right',4X,'total')
30     FORMAT (7X,'----',7X,'------',5X,'----',3X,'-----',3X,'-----',6X,
     +         '----',4X,'-----',4X,'-----')
40     FORMAT (4X,1PE10.3,4X,0PF6.3,4X,F5.3,2(3X,F5.3),
     +  4X,F6.3,2(3X,F6.3))
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE GRFINT
C initialize all graphing variables which are the same for one run
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables
      INCLUDE 'PARAM.E7'
      INCLUDE 'GRFDAT.ALL'
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      YMAX=VMAX                      !find limits on data points
      YMIN=VMIN
      X0VAL=VMIN
      XMIN=VXMIN
      XMAX=VXMAX
      Y0VAL=VXMIN
C
      NPOINT=NPTS+1
C
      ISYM=1                         !symbols and ticks
      IFREQ=0
      NXTICK=5
      NYTICK=5
      ILINE=1
C
      LABEL(1)='scaled X'            !titles and labels
      LABEL(2)='potential, PHI2'
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE GRFOUT(DEVICE,PHI2,TIME,TPROB,TX,E)
C outputs wavepacket and potential to DEVICE
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.E7'
      INCLUDE 'GRFDAT.ALL'
C Input variables:
      INTEGER DEVICE            !which device is being used?
      REAL PHI2(0:MAXLAT)       !wavepacket squared
      REAL TIME                 !time
      REAL TPROB                !normalization of the wavepacket
      REAL TX                   !average position
      REAL E                    !energy
C Local variables
      REAL PHIGRF(0:MAXLAT)     !scaled wavepacket squared
      REAL VSCALE               !scaling factor for PHI2
      INTEGER IX                !lattice index
      CHARACTER *9 CE,CSIG      !Energy, SIGMA as character data
      CHARACTER*9 CPROB,CTX,CTIME !data as characters
      INTEGER PLEN,TXLEN,TLEN,ELEN,SLEN !length of strings
      INTEGER LENTRU            !true length of character data
      INTEGER SCREEN            !send to terminal
      INTEGER PAPER             !make a hardcopy
      INTEGER FILE              !send to a file
      DATA SCREEN,PAPER,FILE/1,2,3/
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     messages for the impatient
      IF (DEVICE .NE. SCREEN) WRITE (OUNIT,100)
C
C     calculate parameters for graphing
      IF (DEVICE .NE. FILE) THEN
C
          IF (.NOT. MOVIES) THEN
            NPLOT=1                        !how many plots?
          ELSE
            NPLOT=4                        !for movies, there are
          END IF                           ! 4 plots per page
          IPLOT=1
C
          CALL CONVRT(TPROB,CPROB,PLEN)    !create legend
          CALL CONVRT(TX,CTX,TXLEN)
          CALL CONVRT(TIME,CTIME,TLEN)
          INFO='t='//CTIME(1:TLEN)//'  norm='//
     +     CPROB(1:PLEN)//'  <X>='//CTX(1:TXLEN)
C
          CALL CONVRT(E,CE,ELEN)           !description of  data
          CALL CONVRT(SIGMA,CSIG,SLEN)
          IF (PACKET .EQ. LORNTZ) THEN
             TITLE='Lorentzian packet,'
          ELSE IF (PACKET .EQ. GAUSS) THEN
             TITLE='Gaussian packet,'
          END IF
          TITLE=TITLE(1:LENTRU(TITLE))//' width='//CSIG(1:SLEN)
     +       //', E ='//CE(1:ELEN)
C
          CALL GTDEV(DEVICE)                   !device nomination
          IF (DEVICE .EQ. SCREEN) CALL GMODE   !change to graphics mode
          CALL LNLNAX                          !draw axes
      END IF
C
C     The largest PHI2(IX) can ever become is 1 (all probability at
C     one lattice point).  The following scale assumes that the maximum
C     value is 10/NPTS (prob equally shared by one-tenth of the points)
      VSCALE=(VMAX-VMIN)*NPTS/10.  !scale PHI2 so that it fits on Vscale
      DO 10 IX=0,NPTS
         PHIGRF(IX)=VMIN+PHI2(IX)*VSCALE
         IF(PHIGRF(IX) .GT. VMAX) PHIGRF(IX)=VMAX   !clip high values
10    CONTINUE
C
C     output results
      IF (DEVICE .EQ. FILE) THEN
         WRITE (GUNIT,60) TIME
         WRITE (GUNIT,70) (X(IX),V(IX),PHI2(IX),IX=1,NPTS)
      ELSE
          CALL XYPLOT (X,V)
          CALL XYPLOT (X,PHIGRF)
      END IF
C
C     end graphing session
      IF (.NOT. MOVIES) THEN
        IF (DEVICE .NE. FILE) CALL GPAGE(DEVICE)  !end graphics package
        IF (DEVICE .EQ. SCREEN) CALL TMODE        !switch to text mode
      END IF
C
60    FORMAT (' X,V, PHI2 at time = ',1PE15.8)
70    FORMAT (3(5X,E15.8))
100   FORMAT (/,' Patience, please; output going to a file.')
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE GRFSEC(DEVICE,PHI2,TIME,TPROB,TX,FRAME)
C outputs wavepacket and potential for movies, frames 2-4
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.E7'
      INCLUDE 'GRFDAT.ALL'
C Input variables:
      INTEGER DEVICE            !which device is being used?
      REAL PHI2(0:MAXLAT)       !wavepacket squared
      REAL TIME                 !time
      REAL TPROB                !normalization of the wavepacket
      REAL TX                   !average position
      INTEGER FRAME             !which frame of the movie is it?
C Local variables
      REAL PHIGRF(0:MAXLAT)     !scaled wavepacket squared
      REAL VSCALE               !scaling factor for PHI2
      INTEGER IX                !lattice index
      CHARACTER*9 CPROB,CTX,CTIME !data as characters
      INTEGER PLEN,TXLEN,TLEN   !length of strings
      INTEGER SCREEN            !send to terminal
      INTEGER PAPER             !make a hardcopy
      INTEGER FILE              !send to a file
      DATA SCREEN,PAPER,FILE/1,2,3/
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IPLOT=FRAME                  !associate plots with frames
      IF (IPLOT .EQ. 0) IPLOT=4
C
      CALL CONVRT(TPROB,CPROB,PLEN)!create legend
      CALL CONVRT(TX,CTX,TXLEN)
      CALL CONVRT(TIME,CTIME,TLEN)
      INFO='t='//CTIME(1:TLEN)//'  norm='//
     +     CPROB(1:PLEN)//'  <X>='//CTX(1:TXLEN)
      CALL LNLNAX                  !draw axes
C
      VSCALE=(VMAX-VMIN)*NPTS/10.  !scale PHI2 so that it fits on Vscale
      DO 10 IX=0,NPTS
         PHIGRF(IX)=VMIN+PHI2(IX)*VSCALE
         IF(PHIGRF(IX) .GT. VMAX) PHIGRF(IX)=VMAX
10    CONTINUE
C
      CALL XYPLOT (X,V)            !plot data
      CALL XYPLOT (X,PHIGRF)
C
      IF (IPLOT .EQ. 4) CALL GPAGE(DEVICE)  !clear this graphics page
C
      RETURN
      END


! An implementation of QuickSort in functional programming style
!
program sortdata
    real, dimension(1000) :: data

    call random_number( data )

    write(*,*) 'First 20: '
    write(*,'(5f10.4)') data(1:20)
    write(*,*) 'Last 20: '
    write(*,'(5f10.4)') data(1000-21:1000)

    data = qsort_reals( data )
    write(*,*) 'Sorted:'
    write(*,*) 'First 20: '
    write(*,'(5f10.4)') data(1:20)
    write(*,*) 'Last 20: '
    write(*,'(5f10.4)') data(1000-21:1000)

contains
recursive function qsort_reals( data ) result( sorted )
    real, dimension(:), intent(in) :: data
    real, dimension(1:size(data))  :: sorted

    if ( size(data) > 1 ) then
        sorted = (/ qsort_reals( pack( data(2:), data(2:) > data(1) ) ), &
                    data(1),                                             &
                    qsort_reals( pack( data(2:), data(2:) <= data(1) ) ) /)
    else
        sorted = data
    endif
end function
end program


c     program DRSERFI
c>> 1996-06-27 DRSERFI  Krogh Minor change in formats for C conversion.
c>> 1996-05-28 DRSERFI  Krogh Added external statement.
c>> 1994-10-19 DRSERFI  Krogh  Changes to use M77CON
c>> 1992-04-21 DRSERFI  CLL
c>> 1991-11-19 CLL
c>> 1987-12-09 DRSERFI  Snyder  Initial Code.
c
c     Demonstration driver for SERFI and SERFCI.
c     ------------------------------------------------------------------
      external R1MACH, SERFI, SERFCI
      real             SERFI, SERFCI, R, X, R1MACH, FLOOR
      integer I
c     ------------------------------------------------------------------
c--S replaces "?": DR?ERFI, ?ERFI, ?ERFCI
c     ------------------------------------------------------------------
   90 format (11x,1p,g12.5,g29.14)
      print '(/11x,''DRSERFI.. Demo driver for SERFI and SERFCI''//
     *   16x,''X'',13x,''SERFI(X) = SERFCI(1-X)'')'
      R = 1.0e-5
      do 10 I = 1,4
         X = 1.0e0 - R
         R = 10.0e0 * R
         print 90, X, SERFI(x)
   10 continue
      X = 0.9e0
      do 20 I = 1,9
         print 90, X, SERFI(x)
         X = X - 0.1e0
   20 continue
      print 90, 1.0e-10, SERFI(1.0e-10)
      print 90, 0.0e0, SERFI(0.0e0)
c
      print '(/16x,''X'',13x,''SERFCI(X) = SERFI(1-X)'')'
      X = 1.0e-10
      FLOOR = R1MACH(1) * 1.0e11
      do 30 I = 1,10
        print 90, X, SERFCI(X)
        if (X .lt. FLOOR) go to 40
        X = 1.0e-10 * X
   30 continue
   40 continue
      stop
      end


subroutine fprint(no,ncase,neqn,t,u)
!
!  Subroutine fprint displays the numerical solution to the
!  nonlinear PDE problem
!
!  Double precision coding is used
implicit double precision(a-h,o-z)
!
!  Global variables
common/p/ alpha, xk, sigma, xl, ui, ua, a, e, rhos, cps, xls, cs
!
!  Size the arrays
dimension u(neqn)
!
!  Print a heading for the solution at t = 0
if(t.le.0.0d0)then
!
!  Label for ODE integrator
!
!  Fixed step modfied Euler
if(ncase.eq.1)then
write(no,11)
11 format(//,' euler2a integrator')
!
!  Variable step modified Euler
else if(ncase.eq.2)then
write(no,12)
12 format(//,' euler2b integrator')
!
!  Fixed step classical fourth order RK
else if(ncase.eq.3)then
write(no,13)
13 format(//,' rkc4a integrator')
!
!  Variable step classical fourth order RK
else if(ncase.eq.4)then
write(no,14)
14 format(//,' rkc4b integrator')
!
!  Fixed step RK Fehlberg 45
else if(ncase.eq.5)then
write(no,15)
15 format(//,' rkf45a integrator')
!
!  Variable step RK Fehlberg 45
else if(ncase.eq.6)then
write(no,16)
16 format(//,' rkf45b integrator')
end if
!
!  Heading
write(no,2)ncase,neqn
2 format(/,' ncase = ',i2,' neqn = ',i2,/)
write(no,3)
3 format(' t u(1) u(im) u(neqn)')
!
!  End of t = 0 heading
end if
!
!  Numerical and analytical solution output
!
!  Grid index of midpoint
im=neqn/2
!
!  Display the numerical solution
tmin=t*xl**2/alpha/60.0d0
write(no,4) tmin, u(1), u(im), u(neqn)
4 format(f6.1,3f10.2)
return
!
!  End of fprint
end


!
! sparse matrix module
!

module sparse
  implicit none
  logical, public, parameter :: Cindex = .true.
  integer, public, parameter :: sparse_base_index = 0 ! Cindex == .true. -> 0, otherwise -> 1

contains

  ! Description:
  !   return the number of non-zero elements (nnz) of matrix A
  ! Parameters:
  !   m: rows of matrix A
  !   n: columns of matrix A
  !   A: 2D-array of A

  function sparse_nnz(m, n, A, lda) result (nnz)
    integer, intent(in) :: m, n, lda
    double precision, intent(in) :: A(1:lda,1:n)
    integer :: i, j, nnz
    nnz = 0
    do j = 1, n
      do i = 1, m
        if (A(i,j) /= 0.0d0) then
          nnz = nnz + 1
        end if
      end do
    end do
  end function sparse_nnz

  ! Description: Transrate from a dense matrix A to CSR format
  ! Parameters:
  !    m: rows of A
  !    n: columns of A
  !  nnz: nnz of A
  !    A: dense matrix
  !  rowptr: rowptr of csr
  !  colind: colind of csr
  !  spA: value

  subroutine dense_to_csr(m, n, A, lda, spA, rowptr, colind, nnz)
    integer, parameter :: base = sparse_base_index
    integer, intent(in) :: m, n, nnz, lda
    double precision, intent(in) :: A(base:base+lda-1,base:base+n-1)
    double precision, intent(out) :: spA(base:base+nnz-1)
    integer, intent(out) :: rowptr(base:base+m), colind(base:base+nnz-1)

    integer :: i, j, z

    z = base
    rowptr(base) = z
    do i = base, base+m-1
       do j = base, base+n-1
          if (A(i,j) /= 0.0d0) then
             spA(z) = A(i,j)
             colind(z) = j
             z = z + 1
          end if
       end do
       rowptr(i+1) = z
    end do
  end subroutine dense_to_csr

  ! Description: Transrate from a dense matrix A to CSC format
  ! Parameters:
  !    m: rows of A
  !    n: columns of A
  !  nnz: nnz of A
  !    A: dense matrix
  !  colptr: colptr of csc
  !  rowind: rowind of csc
  !  spA: value

  subroutine dense_to_csc(m, n, A, lda, spA, colptr, rowind, nnz)
    integer, parameter :: base = sparse_base_index
    integer, intent(in) :: m, n, nnz, lda
    double precision, intent(in) :: A(base:base+lda-1,base:base+n-1)
    double precision, intent(out) :: spA(base:base+nnz-1)
    integer, intent(out) :: colptr(base:base+n), rowind(base:base+nnz-1)

    integer :: i, j, z

    z = base
    colptr(base) = z
    do j = base, base+n-1
       do i = base, base+m-1
          if (A(i,j) /= 0.0d0) then
             spA(z) = A(i,j)
             rowind(z) = i
             z = z + 1
          end if
       end do
       colptr(j+1) = z
    end do
  end subroutine dense_to_csc

  ! Description: Transrate from a dense matrix A to COO format
  ! Parameters:
  !    m: rows of A
  !    n: columns of A
  !  nnz: nnz of A
  !    A: dense matrix
  !  rowind: colptr of coo
  !  colind: rowind of coo
  !  spA: value

  subroutine dense_to_coo(m, n, A, lda, spA, rowind, colind, nnz)
    integer, parameter :: base = sparse_base_index
    integer, intent(in) :: m, n, nnz, lda
    double precision, intent(in) :: A(base:base+lda-1,base:base+n-1)
    double precision, intent(out) :: spA(base:base+nnz-1)
    integer, intent(out) :: rowind(base:base+nnz-1), colind(base:base+nnz-1)

    integer :: i, j, z

    z = base
    do j = base, base+n-1
       do i = base, base+m-1
          if (A(i,j) /= 0.0d0) then
             spA(z) = A(i,j)
             rowind(z) = i
             colind(z) = j
             z = z + 1
          end if
       end do
    end do
  end subroutine dense_to_coo

  ! Description: Transrate from a spase matrix to a
  !              dense matrix
  ! Parameters:
  !    m: rows of spA
  !    n: columns of spA
  !    nnz: nnz of spA
  !    spA: value of spA
  !    rowptr: rowptr of spA
  !    colind: colind of spA
  !    A: dense matrix
  !

  subroutine csr_to_dense(m, n, spA, rowptr, colind, nnz, A, lda)
    integer, parameter :: base = sparse_base_index
    integer, intent(in) :: m, n, nnz, lda
    double precision, intent(in) :: spA(base:base+nnz-1)
    integer, intent(in) :: rowptr(base:base+m), colind(base:base+nnz-1)
    double precision, intent(out) :: A(base:base+lda-1,base:base+n-1)

    integer :: i, z

    A(base:base+m-1,base:base+n-1) = 0.0d0
    do i = base, base+m-1
       do z = rowptr(i), rowptr(i+1)-1
          A(i,colind(z)) = spA(z)
       end do
    end do
  end subroutine csr_to_dense

  ! Description: Transrate from a spase matrix to a
  !              dense matrix
  ! Parameters:
  !    m: rows of spA
  !    n: columns of spA
  !    nnz: nnz of spA
  !    spA: value of spA
  !    colptr: rowptr of spA
  !    rowind: colind of spA
  !    A: dense matrix
  !

  subroutine csc_to_dense(m, n, spA, colptr, rowind, nnz, A, lda)
    integer, parameter :: base = sparse_base_index
    integer, intent(in) :: m, n, nnz, lda
    double precision, intent(in) :: spA(base:base+nnz-1)
    integer, intent(in) :: colptr(base:base+n), rowind(base:base+nnz-1)
    double precision, intent(out) :: A(base:base+lda-1,base:base+n-1)

    integer :: j, z

    A(base:base+m-1,base:base+n-1) = 0.0d0
    do j = base, base+n-1
       do z = colptr(j), colptr(j+1)-1
          A(rowind(z),j) = spA(z)
       end do
    end do
  end subroutine csc_to_dense

  ! Description: Transrate from a spase matrix to a
  !              dense matrix
  ! Parameters:
  !    m: rows of spA
  !    n: columns of spA
  !    nnz: nnz of spA
  !    spA: value of spA
  !    rowind: rowptr of spA
  !    colind: colind of spA
  !    A: dense matrix
  !

  subroutine coo_to_dense(m, n, spA, rowind, colind, nnz, A, lda)
    integer, parameter :: base = sparse_base_index
    integer, intent(in) :: m, n, nnz, lda
    double precision, intent(in) :: spA(base:base+nnz-1)
    integer, intent(in) :: rowind(base:base+nnz-1), colind(base:base+nnz-1)
    double precision, intent(out) :: A(base:base+lda-1,base:base+n-1)

    integer :: z

    A(base:base+m-1,base:base+n-1) = 0.0d0
    do z = base, base+nnz-1
      A(rowind(z),colind(z)) = spA(z)
    end do
  end subroutine coo_to_dense

end module sparse


!-----------------------------------------------------------------------
      program test
      implicit none
      include 'ceedf.h'

      integer ceed,err
      integer u,v
      integer qf
      integer q,i
      parameter(q=8)
      real*8 uu(q)
      real*8 vv(q)
      character arg*32
      integer*8 uoffset,voffset

      call getarg(1,arg)
      call ceedinit(trim(arg)//char(0),ceed,err)

      call ceedqfunctioncreateidentity(ceed,1,ceed_eval_interp,&
     & ceed_eval_interp,qf,err)

      do i=0,q-1
        uu(i+1)=i*i
      enddo

      call ceedvectorcreate(ceed,q,u,err)
      uoffset=0
      call ceedvectorsetarray(u,ceed_mem_host,ceed_use_pointer,uu,uoffset,err)
      call ceedvectorcreate(ceed,q,v,err)
      call ceedvectorsetvalue(v,0.d0,err)

      call ceedqfunctionapply(qf,q,u,ceed_null,ceed_null,ceed_null,&
             &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,&
             &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,&
             &v,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,&
             &ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,ceed_null,&
             &ceed_null,ceed_null,ceed_null,ceed_null,err)

      call ceedvectorgetarrayread(v,ceed_mem_host,vv,voffset,err)
      do i=1,q
        if (abs(vv(i+voffset)-(i-1)*(i-1)) > 1.0D-14) then
! LCOV_EXCL_START
          write(*,*) 'v(i)=',vv(i+voffset),', u(i)=',(i-1)*(i-1)
! LCOV_EXCL_STOP
        endif
      enddo
      call ceedvectorrestorearrayread(v,vv,voffset,err)

      call ceedvectordestroy(u,err)
      call ceedvectordestroy(v,err)
      call ceedqfunctiondestroy(qf,err)
      call ceeddestroy(ceed,err)
      end
!-----------------------------------------------------------------------


* This file contains the following subroutines, related to specifying
* physical spectral weighting functions:
*     swphys

*=============================================================================*

      SUBROUTINE swphys(nw,wl,wc,j,s,label)

*-----------------------------------------------------------------------------*
*=  PURPOSE:                                                                 =*
*=  Create or read various spectral weighting functions, physically-based    =*
*=  e.g. UV-B, UV-A, visible ranges, instrument responses, etc.              =*
*-----------------------------------------------------------------------------*
*=  PARAMETERS:                                                              =*
*=  NW     - INTEGER, number of specified intervals + 1 in working        (I)=*
*=           wavelength grid                                                 =*
*=  WL     - REAL, vector of lower limits of wavelength intervals in      (I)=*
*=           working wavelength grid                                         =*
*=  WC     - REAL, vector of central wavelength of wavelength intervals    I)=*
*=           in working wavelength grid                                      =*
*=  J      - INTEGER, counter for number of weighting functions defined  (IO)=*
*=  S      - REAL, value of each defined weighting function at each       (O)=*
*=           defined wavelength                                              =*
*=  LABEL  - CHARACTER*40, string identifier for each weighting function  (O)=*
*=           defined                                                         =*
*-----------------------------------------------------------------------------*

      IMPLICIT NONE
      INCLUDE 'params'

      INTEGER kdata
      PARAMETER(kdata=1000)

* input:
      REAL wl(kw), wc(kw)
      INTEGER nw

* input/output:
      INTEGER j

* output: (weighting functions and labels)
      REAL s(ks,kw)
      CHARACTER*50 label(ks)

* internal:
      REAL x1(kdata)
      REAL y1(kdata)
      REAL yg(kw)

      INTEGER i, iw, n

      INTEGER ierr

      INTEGER idum
      REAL dum1, dum2
      REAL em, a, b, c
      REAL sum

*_______________________________________________________________________

      j = 0

********* UV-B (280-315 nm)

      j = j + 1
      label(j) = 'UV-B, 280-315 nm'
      DO iw = 1, nw-1
         IF (wc(iw) .GT. 280. .AND. wc(iw) .LT. 315.) THEN
            s(j,iw) = 1.
         ELSE
            s(j,iw) = 0.
         ENDIF
      ENDDO

********* UV-B* (280-320 nm)

      j = j + 1
      label(j) = 'UV-B*, 280-320 nm'
      DO iw = 1, nw-1
         IF (wc(iw) .GT. 280. .AND. wc(iw) .LT. 320.) THEN
            s(j,iw) = 1.
         ELSE
            s(j,iw) = 0.
         ENDIF
      ENDDO

********* UV-A (315-400 nm)

      j = j + 1
      label(j) = 'UV-A, 315-400 nm'
      DO iw = 1, nw-1
         IF (wc(iw) .GT. 315. .AND. wc(iw) .LT. 400.) THEN
            s(j,iw) = 1.
         ELSE
            s(j,iw) = 0.
         ENDIF
      ENDDO

********* visible+ (> 400 nm)

      j = j + 1
      label(j) = 'vis+, > 400 nm'
      DO iw = 1, nw-1
         IF (wc(iw) .GT. 400. .AND. wc(iw) .LT. 700.) THEN
            s(j,iw) = 1.
         ELSE
            s(j,iw) = 0.
         ENDIF
      ENDDO

**********  Gaussian transmission functions

      j = j + 1
      label(j) = 'Gaussian, 305 nm, 10 nm FWHM'
      sum = 0.
      DO iw = 1, nw-1
         s(j,iw) = exp(- ( log(2.) * ((wc(iw)-305.)/(5.))**2) )
         sum = sum + s(j,iw)
      ENDDO
      DO iw = 1, nw-1
         s(j,iw) = s(j,iw)/sum
      ENDDO

      j = j + 1
      label(j) = 'Gaussian, 320 nm, 10 nm FWHM'
      sum = 0.
      DO iw = 1, nw-1
         s(j,iw) = exp(- ( log(2.) * ((wc(iw)-320.)/(5.))**2) )
         sum = sum + s(j,iw)
      ENDDO
      DO iw = 1, nw-1
         s(j,iw) = s(j,iw)/sum
      ENDDO

      j = j + 1
      label(j) = 'Gaussian, 340 nm, 10 nm FWHM'
      sum = 0.
      DO iw = 1, nw-1
         s(j,iw) = exp(- ( log(2.) * ((wc(iw)-340.)/(5.))**2) )
         sum = sum + s(j,iw)
      ENDDO
      DO iw = 1, nw-1
         s(j,iw) = s(j,iw)/sum
      ENDDO

      j = j + 1
      label(j) = 'Gaussian, 380 nm, 10 nm FWHM'
      sum = 0.
      DO iw = 1, nw-1
         s(j,iw) = exp(- ( log(2.) * ((wc(iw)-380.)/(5.))**2) )
         sum = sum + s(j,iw)
      ENDDO
      DO iw = 1, nw-1
         s(j,iw) = s(j,iw)/sum
      ENDDO

********** RB Meter, model 501
*  private communication, M. Morys (Solar Light Co.), 1994.
* From: morys@omni.voicenet.com (Marian Morys)
* Received: from acd.ucar.edu by sasha.acd.ucar.edu (AIX 3.2/UCB 5.64/4.03)
*          id AA17274; Wed, 21 Sep 1994 11:35:44 -0600

      j = j + 1
      label(j) = 'RB Meter, model 501'
      OPEN(UNIT=kin,FILE='DATAS1/rbm.501',STATUS='old')
      n = 57
      DO i = 1, n
         READ(kin,*) x1(i), y1(i)
      ENDDO
      CLOSE (kin)

      CALL terint(nw,wl,yg, n,x1,y1, 1,0)

      DO iw = 1, nw-1
         s(j,iw) = yg(iw)
      ENDDO

********** Eppley UV Photometer
* CAUTION:
*    Contrary to the manufacturer's claims, the Eppley Total UV photometer does
* not measure integrated uv radiation in any wavelength band.  It actually
* measures the *average* spectral irradiance over 295-385 nm, with the
* averaging kernel given by the instrument's spectral response function
* (which is the product of the photodiode response and the filter transmission
* function).
*    The calibration factor provided by Eppley Laboratories Inc. is only valid
* when the photometer is exposed to a spectrum that has the same shape as their
* calibration lamp.  The calibration factor is not accurate for exposure to the
* solar spectrum.  The values of Eppley total UV irradiance for outdoor
* observations, although reported as W m-2, should be used with caution and
* cannot be associated to any specific physical quantity, such as UVA,
* UVA + UVB, the 295-385 nm band, or the 295-400 nm band.
*    The value calculated here is the average spectral irradiance using the
* Eppley repsonse kernel, then multiplied by the nominal bandwith of 90 nm
* (295-385 nm). This value is about 10% higher than the un-weighted integral
* over 295-385 nm, and about 10% lower than the UVA (315-400 nm).
* - Sasha Madronich, March 2009

      j = j + 1
      label(j) = 'Eppley UV Photometer'
      OPEN(UNIT=kin,FILE='DATAS1/eppley_uv',STATUS='old')
      DO i = 1, 6
         READ(kin,*)
      ENDDO
      n = 19
      DO i = 1, n
         READ(kin,*) x1(i), dum1, dum2
         y1(i) = dum1*dum2
      ENDDO
      CLOSE(kin)

      CALL terint(nw,wl,yg, n,x1,y1, 1,0)

* compute normalization

      sum = 0.
      DO iw = 1, nw-1
         sum = sum + yg(iw)*(wl(iw+1) - wl(iw))
      ENDDO

      DO iw = 1, nw-1
         s(j,iw) = 90.*yg(iw)/sum
      ENDDO

****************************************************************
****************************************************************

*_______________________________________________________________________

      IF (j .GT. ks) STOP '1001'
*_______________________________________________________________________

      RETURN
      END


      SUBROUTINE ZPGORD( WANTQ, K, N, S, SELECT, A, LDA1, LDA2,
     $                   ALPHA, BETA, SCAL, Q, LDQ1, LDQ2, M,
     $                   ZWORK, LZWORK, INFO )
	IMPLICIT NONE
C
C     PURPOSE
C
C     ZPGORD reorders the periodic Schur decomposition of a complex
C     generalized matrix product
C
C                                 S(2)                 S(K)
C          A(:,:,1)     * A(:,:,2)     * ... * A(:,:,K),
C
C     (in terms of unitary equivalence transformations), so that a
C     selected cluster of eigenvalues appears in the leading diagonal
C     blocks of the matrix product. The leading columns of the
C     orthogonal factors contained in Q form unitary bases of the
C     corresponding periodic eigenspaces (deflating subspaces).
C     A must be in periodic Schur form, that is, all factors of A must
C     be upper triangular.
C
C     If WANTQ = .TRUE., then the unitary factors are computed and
C     stored in the array Q so that for S(I) = 1,
C
C                         H
C             Q(:,:,I)(in)   A(:,:,I)(in)   Q(:,:,MOD(I,K)+1)(in)
C                          H                                        (1)
C         =   Q(:,:,I)(out)  A(:,:,I)(out)  Q(:,:,MOD(I,K)+1)(out),
C
C     and for S(I) = -1,
C
C                                  H
C             Q(:,:,MOD(I,K)+1)(in)   A(:,:,I)(in)   Q(:,:,I)(in)
C                                   H                               (2)
C         =   Q(:,:,MOD(I,K)+1)(out)  A(:,:,I)(out)  Q(:,:,I)(out).
C
C     ARGUMEMTS
C
C     Mode Parameters
C
C     WANTQ   (input) LOGICAL
C             = .FALSE.: do not modify Q;
C             = .TRUE. : modify the array Q by the unitary
C                        transformations that are applied to the
C                        matrices in A for reordering.
C
C     Input/Output Parameters
C
C     K       (input)  INTEGER
C             The number of factors.  K >= 1.
C
C     N       (input)  INTEGER
C             The order of each factor in A.  N >= 0.
C
C     S       (input)  INTEGER array, dimension (K)
C             The leading K elements of this array must contain the
C             signatures of the factors. Each entry in S must be either
C             1 or -1. By definition, S(1) must be set to 1.
C
C     SELECT  (input) LOGICAL array, dimension (N)
C             SELECT specifies the eigenvalues in the selected cluster.
C             To select the eigenvalue corresponding to the (j,j)
C             diagonal entries, SELECT(j) must be set to .TRUE..
C
C     A       (input/output) COMPLEX*16 array, dimension (LDA1,LDA2,K)
C             On entry, the leading N-by-N-by-K part of this array
C             must contain the factors in periodic Schur form
C             form, that is, all factors are upper triangular.
C             On exit, if INFO = 0, the leading N-by-N-by-K part of
C             this array contains the factors of the reordered periodic
C             Schur form. Moreover, A(:,:,2), ..., A(:,:,K) are
C             normalized so that their diagonals contain nonnegative
C             real numbers.
C
C     LDA1    (input) INTEGER
C             The first leading dimension of A.  LDA1 >= MAX(1,N).
C
C     LDA2    (input) INTEGER
C             The second leading dimension of A.  LDA2 >= MAX(1,N).
C
C     Q       (input/output) COMPLEX*16 array, dimension (LDQ1,LDQ2,K)
C             On entry, if WANTQ = .TRUE., the leading N-by-N-by-K part
C             of this array must contain the initial unitary factors
C             as described in (1)-(2).
C             On exit, if WANTQ = .TRUE., the leading N-by-N-by-K part
C             of this array contains the modified orthogonal factors as
C             described in (1)-(2).
C
C     LDQ1    (input)  INTEGER
C             The first leading dimension of Q.
C             If WANTQ = .TRUE.,  LDQ1 >= MAX(1,N).
C
C     LDQ2    (input)  INTEGER
C             The second leading dimension of Q.
C             If WANTQ = .TRUE.,  LDQ2 >= MAX(1,N).
C
C     M       (output) INTEGER
C             The dimension of the specified periodic eigenspace.
C
C     Workspace
C
C     ZWORK   COMPLEX*16 array, dimension (LZWORK)
C             On exit, if INFO = 0, ZWORK(1) returns the minimal value
C             of LZWORK.
C
C     LZWORK  INTEGER
C             The length of the array ZWORK.  LZWORK >= MAX( K, N ).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0       : succesful exit;
C             < 0       : if INFO = -i, the i-th argument had an
C                         illegal value;
C             = 1       : the periodic QZ algorithm failed to converge.
C
C     METHOD
C
C     A complex version of the periodic QZ algorithm [1] with
C     perfect shifts is used. For more details see [2]. This is not
C     a safe method. It is advisable to check whether the eigenvalues
C     are really reorderd.
C
C     REFERENCES
C
C     [1] Bojanczyk, A. and Golub, G. H. and Van Dooren, P.
C         The periodic Schur decomposition; algorithm and applications.
C         In Proc. SPIE Conference, pg. 31-42, vol. 1770, 1992.
C
C     [2] Kressner, D.
C         An efficient and reliable implementation of the periodic QZ
C         algorithm. In IFAC Workshop on Periodic Control Systems, 2001.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically backward stable.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Berlin, Germany, Dec. 2002.
C
C     ******************************************************************
C
C     .. Parameters ..
      COMPLEX*16        CONE, CZERO
      PARAMETER         ( CONE = ( 1.0D+0, 0.0D+0 ),
     $                  CZERO = ( 0.0D+0, 0.0D+0 ) )
C     .. Scalar Arguments ..
      LOGICAL           WANTQ
      INTEGER           K, INFO, LDA1, LDA2, LDQ1, LDQ2, LZWORK, M, N
C     .. Array Arguments ..
      LOGICAL           SELECT(*)
      INTEGER           S(*), SCAL(*)
      COMPLEX*16        A(LDA1, LDA2, *), ALPHA(*), BETA(*),
     $                  Q(LDQ1, LDQ2, *), ZWORK(*)
C     .. Local Scalars ..
      LOGICAL           SOK
      INTEGER           I, IERR, J, JS, L
	DOUBLE PRECISION  ABST, BASE, SAFMIN
	COMPLEX*16        TEMP
C     .. Local Arrays ..
	DOUBLE PRECISION  DLAMCH
      EXTERNAL          DLAMCH
C     .. External Subroutines ..
      EXTERNAL          ZLAPR1, ZPGEX2, ZSCAL
C     .. Intrinsic Functions ..
      INTRINSIC         DCMPLX, DCONJG, MAX
C
C     .. Executable Statements ..
C
      INFO = 0
	SAFMIN = DLAMCH( 'SafeMinimum' )
      BASE = DLAMCH( 'Base' )
C
C     Check the scalar input parameters.
C
      IF ( K.LT.1 ) THEN
         INFO = -2
      ELSE IF ( N.LT.0 ) THEN
         INFO = -3
      ELSE
	   SOK = S(1).EQ.1
	   DO 10  L = 2, K
	      SOK = S(L).EQ.1 .OR. S(L).EQ.-1
   10    CONTINUE
         IF ( .NOT.SOK ) THEN
	      INFO = -4
         ELSE IF ( LDA1 .LT. MAX( 1, N ) ) THEN
            INFO = -7
         ELSE IF ( LDA2 .LT. MAX( 1, N ) ) THEN
            INFO = -8
         ELSE IF ( WANTQ .AND. LDQ1.LT.MAX( 1, N ) ) THEN
            INFO = -13
         ELSE IF ( WANTQ .AND. LDQ2.LT.MAX( 1, N ) ) THEN
            INFO = -14
	   ELSE IF ( LZWORK.LT.MAX( K, N ) ) THEN
            INFO = -17
         END IF
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZPGORD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         ZWORK(1) = CONE
         RETURN
      END IF
C
C     Set M to the dimension of the specified deflating subspace.
C
      M = 0
      DO 20 J = 1, N
         IF ( SELECT( J ) )
     $      M = M + 1
   20 CONTINUE
C
      JS = 0
      DO 40 J = 1, N
         IF ( SELECT( J ) ) THEN
            JS = JS + 1
C
C           Swap the J-th block to position JS.
C
            IF ( J.NE.JS ) THEN
	         DO 30  I = J-1, JS, -1
                  CALL ZPGEX2( .TRUE., K, N, I, S, A, LDA1, LDA2, Q,
     $                         LDQ1, LDQ2, ZWORK, IERR )
	            IF ( IERR.NE.0 ) THEN
	               INFO = 1
	               GO TO 120
	            END IF
   30          CONTINUE
	      END IF
         END IF
   40 CONTINUE
C
C     Rescale matrices and recompute eigenvalues.
C
      DO 100  L = K, 2, -1
	   IF ( S(L).EQ.1 )  THEN
	      DO 50 J = 1, N
               ABST = ABS( A(J,J,L) )
               IF ( ABST.GT.SAFMIN ) THEN
                  TEMP = DCONJG( A(J,J,L) / ABST )
                  A(J,J,L ) = ABST
                  CALL ZSCAL( N-J, TEMP, A(J,J+1,L), LDA1 )
	         ELSE
	            TEMP = CONE
	         END IF
               ZWORK(J) = TEMP
   50       CONTINUE
	   ELSE
            DO 60  J = 1, N
               ABST = ABS( A(J,J,L) )
               IF ( ABST.GT.SAFMIN ) THEN
                  TEMP = DCONJG( A(J,J,L) / ABST )
                  A(J,J,L ) = ABST
                  CALL ZSCAL( J-1, TEMP, A(1,J,L), 1 )
	         ELSE
	            TEMP = CONE
	         END IF
               ZWORK(J) = DCONJG(TEMP)
   60       CONTINUE
	   END IF
         IF ( WANTQ ) THEN
	      DO 70  J = 1, N
               CALL ZSCAL( N, DCONJG( ZWORK(J) ), Q(1,J,L), 1 )
   70       CONTINUE
         END IF
         IF ( S(L-1).EQ.1 )  THEN
	      DO 80  J = 1, N
	         CALL ZSCAL( J, DCONJG( ZWORK(J) ), A(1,J,L-1), 1 )
   80       CONTINUE
         ELSE
	      DO 90  J = 1, N
	         CALL ZSCAL( N-J+1, ZWORK(J), A(J,J,L-1), LDA1 )
   90       CONTINUE
	   END IF
  100 CONTINUE
      DO 110  J = 1, N
         CALL ZLAPR1( BASE, K, S, A(J,J,1), LDA1*LDA2, ALPHA(J),
     $                BETA(J), SCAL(J) )
  110 CONTINUE
C
  120 CONTINUE
      ZWORK(1) = DCMPLX( MAX( K, N ), 0 )
      RETURN
C *** Last line of ZPGORD ***
      END


!----------------------------------------------------------------------------- best with 100 columns

function edgeFEM1() result(ierr)
  use modPolyEdgeFeGrid
  use modFileIO
  use modSparse
  use modEdgeFEM
  type(polyEdgeFeGrid)::grid
  type(multiFront)::curlCurl
  double precision,allocatable::A(:),rhs(:),J(:,:),H(:,:),full(:,:)
  logical,allocatable::isInactive(:)
  integer::ierr

  ierr=0
  open(10,file='data/wireInBox.msh',action='read')
    call readGMSH(10,grid)
  close(10)
  call grid%up()

  allocate(A(grid%nEdge))
  allocate(rhs(grid%nEdge))
  allocate(isInactive(grid%nEdge))
  allocate(J(3,grid%nC))
  allocate(H(3,grid%nC))
  allocate(full(3,grid%nE))

  J(:,:)=0d0
  rhs(:)=0d0
  isInactive(:)=.false.
  do i=1,grid%nC
    if(grid%gid(i)==2)then
      J(:,i)=[0d0,0d0,1d3]
    end if
  end do
  call findVolVectSrc(grid,J,rhs)
  do i=grid%nC+1,grid%nE
    if(grid%gid(i)==11.or.grid%gid(i)==12.or.grid%gid(i)==15.or.grid%gid(i)==17.or.&
    &  grid%gid(i)==13.or.grid%gid(i)==14.or.grid%gid(i)==18.or.grid%gid(i)==16)then
      isInactive(grid%iEdgeE(1:grid%nEdgeE(i),i))=.true.
      rhs(grid%iEdgeE(1:grid%nEdgeE(i),i))=0d0
    end if
  end do
  call curlCurl%init(grid%nEdge,size(grid%iEdgeE,1)**2*grid%nC)
  call findCurlCurl(grid,curlCurl,isInactive)

  call curlCurl%fact()
  call curlCurl%solve(rhs,A)

  call findCellCurl(grid,A,H)

  open(10,file='edgeFEM1.vtk',action='write')
  call writeVTK(10,grid)
  call writeVTK(10,grid,E_DATA)
  full(:,:)=0d0
  full(:,1:grid%nC)=H(:,:)
  call writeVTK(10,'H',full)
  full(:,:)=0d0
  full(:,1:grid%nC)=J(:,:)
  call writeVTK(10,'J',full)
  close(10)

end function


module interpolation_utilities

contains

subroutine interpolate_monthly(now_time, vector_length, monthly_var, interp_var)

use machine , only : kind_phys
use time_utilities

implicit none

double precision                  :: now_time
integer                           :: vector_length
real, dimension(vector_length,12) :: monthly_var
real(kind=kind_phys), dimension(vector_length)    :: interp_var
!real, dimension(vector_length)    :: interp_var

character*19        :: before_date, after_date, current_date  ! format: yyyy-mm-dd hh:nn:ss
double precision    :: before_time, after_time
real                :: before_weight, after_weight
integer             :: before_mm, after_mm, iloop
integer             :: current_yyyy, current_mm, current_dd

! get the current date string assuming reference_date

call date_from_since("1970-01-01 00:00:00", now_time, current_date)

! assume the monthly data are valid on the 15th

before_date = current_date(1:7)//"-15 00:00:00"
after_date  = current_date(1:7)//"-15 00:00:00"

read(current_date( 1: 4),  '(i4)') current_yyyy
read(current_date( 6: 7),  '(i2)') current_mm
read(current_date( 9:10),  '(i2)') current_dd

if(current_dd < 15) then
  if(current_mm == 1) then
    write(before_date( 1: 4),  '(i4.4)') current_yyyy - 1
    write(before_date( 6: 7),  '(i2.2)') 12
  else
    write(before_date( 6: 7),  '(i2.2)') current_mm - 1
  end if
else
  if(current_mm == 12) then
    write(after_date( 1: 4),  '(i4.4)') current_yyyy + 1
    write(after_date( 6: 7),  '(i2.2)') 1
  else
    write(after_date( 6: 7),  '(i2.2)') current_mm + 1
  end if
end if

! get the time the month before and after assuming reference date

call calc_sec_since("1970-01-01 00:00:00",before_date,0,before_time)
call calc_sec_since("1970-01-01 00:00:00", after_date,0, after_time)

if(before_time > now_time .or. after_time < now_time) &
   stop "problem with time in interpolate_monthly"

 after_weight = (now_time - before_time) / (after_time - before_time)
before_weight = 1.0 - after_weight

read(before_date( 6: 7),  '(i2)') before_mm
read( after_date( 6: 7),  '(i2)')  after_mm

do iloop = 1, vector_length

  interp_var(iloop) = before_weight * monthly_var(iloop,before_mm) + &
                       after_weight * monthly_var(iloop,after_mm)

end do

end subroutine interpolate_monthly

subroutine interpolate_linear(now_time, last_time, next_time, vector_length, &
                              last_var, next_var, interp_var)

use machine ,   only : kind_phys
implicit none

double precision                  :: now_time, last_time, next_time
integer                           :: vector_length
real(kind=kind_phys), dimension(vector_length)    :: last_var, next_var, interp_var

real                              :: last_weight, next_weight

if(last_time > now_time .or. next_time < now_time) &
   stop "problem with time in interpolate_linear"

 next_weight = (now_time - last_time) / (next_time - last_time)
 last_weight = 1.0 - next_weight

  interp_var = last_weight * last_var + next_weight * next_var

end subroutine interpolate_linear

subroutine interpolate_gswp3_zenith(now_time, last_time, vector_length, &
                                    latitude, longitude, timestep,      &
                                    last_var, interp_var)

use machine ,   only : kind_phys
use cosine_zenith

implicit none

double precision                  :: now_time, last_time
integer                           :: vector_length, timestep
real, dimension(vector_length)    :: latitude, longitude
real(kind=kind_phys), dimension(vector_length)    :: last_var, interp_var

double precision                  :: calc_time
real(kind=kind_phys), dimension(vector_length)    :: cosz1, cosz2, cosz3, coszavg, cosz

real(kind=kind_phys)                              :: julian
real, parameter                   :: critical_energy = 50.0
real, parameter                   :: critical_cosz   = 0.0001

  if(now_time < last_time) &
     stop "problem with time in interpolate_zenith_angle"

! calculate zenith angle between the model timesteps for this forcing average

  calc_time = last_time + 0.5*timestep
  call calc_cosine_zenith(calc_time, vector_length, latitude, longitude, cosz1, julian)

  calc_time = last_time + 0.5*timestep + timestep
  call calc_cosine_zenith(calc_time, vector_length, latitude, longitude, cosz2, julian)

  calc_time = last_time + 0.5*timestep + 2*timestep
  call calc_cosine_zenith(calc_time, vector_length, latitude, longitude, cosz3, julian)

  where(cosz1 <= critical_cosz) cosz1 = 0.0
  where(cosz2 <= critical_cosz) cosz2 = 0.0
  where(cosz3 <= critical_cosz) cosz3 = 0.0

  coszavg = (cosz1 + cosz2 + cosz3) / 3.0

  interp_var = 0.0

! find which time to interpolate

  if(now_time == last_time) then
    cosz = cosz1
  elseif(now_time == last_time + real(timestep)) then
    cosz = cosz2
  elseif(now_time == last_time + real(2*timestep)) then
    cosz = cosz3
  else
    stop "problem interpolating in gswp3_zenith"
  end if

  where(coszavg > 0.0) interp_var = cosz/coszavg*last_var

! final data check

where(interp_var < 0.0 .or. cosz <= 0.0) interp_var = 0.0

end subroutine interpolate_gswp3_zenith

end module interpolation_utilities


c		***** program for simple harmonic motion ****

		parameter(iobs = 1000, itime = 1000,delta=0.0002)
		parameter(xposeq = 0.0, val=1.000)
c		dimension xpos(0:itime*iobs)

c		*** initial position ***

		xpos1 = 0.0
		xpos2 = 0.01

c                **************************

c		*** Verlet's dynamics ***

		do iyy =1,iobs

		do ixx = 1, itime

c               **** force calculation ***
                force = - val*(xpos2-xposeq)
		xpos3 = 2.0*xpos2 - xpos1 + force*(delta**2)
		xpos1 = xpos2
		xpos2 = xpos3
		end do

		write(12,*) iyy*itime*delta,xpos3

		end do

		stop
		end


program mg_testrelax

  use mg_mpi
  use mg_tictoc
  !  use mg_grids
  !  use mg_define_rhs
  !  use mg_define_matrix
  !  use mg_relax
  !  use mg_intergrids
  use mg_seamount
  !  use mg_solvers
  use nhydro

  implicit none

  integer(kind=ip):: nxg    ! global x dimension
  integer(kind=ip):: nyg    ! global y dimension
  integer(kind=ip):: nzg    ! z dimension
  integer(kind=ip):: npxg   ! number of processes in x
  integer(kind=ip):: npyg   ! number of processes in y
  integer(kind=ip):: it     ! iteration loop number
  integer(kind=ip):: nit    ! number of iterations
  integer(kind=ip) :: nx, ny, nz ! local dimensions

  integer(kind=ip):: nsweeps

  integer(kind=ip):: lev,ierr, np, nh, rank,k
  real(kind=rp)    :: res,conv,res0,bnorm

  real(kind = lg) :: tstart,tend,perf
  real(kind=rp) :: rnxg,rnyg,rnzg
  real(kind=rp) :: rnpxg,rnpyg

  character(len = 16) :: filen

  call tic(1,'mg_testrelax')

  !---------------!
  !- Ocean model -!
  !---------------!
  nxg   = 512
  nyg   = 512
  nzg   = 32

  Lx =  200d3
  Ly =  200d3
  Htot = 4d3

!!$  nxg   = 128
!!$  nyg   = 128
!!$  nzg   = 128
!!$
!!$  Lx =  20d3
!!$  Ly =  20d3
!!$  Htot = 4d3

  hc      = 100.
  theta_b = 0.
  theta_s = 3.

  npxg  = 2
  npyg  = 2

  nit     = 4
  nsweeps = 2

  call mpi_init(ierr)
  call mpi_comm_rank(mpi_comm_world, rank, ierr)
  call mpi_comm_size(mpi_comm_world, np, ierr)

  if (np /= (npxg*npyg)) then
     write(*,*) "Error: in number of processes !"
     stop -1
  endif

  nx = nxg / npxg
  ny = nyg / npyg
  nz = nzg

  !- read the NonHydro namelist file if it is present
  !- else default values and print them (or not).
  call read_nhnamelist(vbrank=rank)

  !-------------------!
  !- Enter in nhydro -!
  !-------------------!
  call mg_mpi_init()
  call define_grids(npxg, npyg, nx, ny, nz)
  call define_neighbours()
  call print_grids()
  !!call define_rhs(nxg, nyg, npxg)

  call setup_realistic_matrix()!2d4,2d4,4d3)
  nh = grid(1)%nh

  do lev=1,1!nlevs
     if (myrank.eq.0)write(*,*)'----------------------------------------'

     grid(lev)%p = 0._8
     !     grid(lev)%b = 0._8
     !     call random_number(grid(lev)%p)
     !     call random_number(grid(lev)%b)
     !     grid(lev)%b(grid(lev)%nz,:,:)= 0.
     do k=1,grid(lev)%nz
        grid(lev)%p(k,:,:)= grid(lev)%p(k,:,:)*grid(lev)%rmask
        !        grid(lev)%b(k,:,:)= (2*grid(lev)%b(k,:,:)-1.)*grid(lev)%rmask
     enddo
     call fill_halo(lev,grid(lev)%p)
     !     call fill_halo(lev,grid(lev)%b)
     call setup_rhs(nx,ny,nz,nh,grid(lev)%b)

     if (netcdf_output) then
        call write_netcdf(grid(lev)%b,vname='rhs',netcdf_file_name='rhs.nc',rank=myrank)
     endif

     call norm(lev,grid(lev)%b,grid(lev)%b,nx,ny,nz,bnorm)

     call cpu_time(tstart)
     do it=0, nit
        !if(it>0) call Vcycle(lev)
        !if(it>0) call Vcycle2(lev,lev+5)
        if(it>0) call Fcycle()
        !if(it>0)call relax(lev,nsweeps)
        call compute_residual(lev,res)
        res=sqrt(res/bnorm)

        if (netcdf_output) then
           write(filen,'("r_",i0.2,".nc")') it
           call write_netcdf(grid(lev)%r,vname='r',netcdf_file_name=filen,rank=myrank)
           write(filen,'("p_",i0.2,".nc")') it
           call write_netcdf(grid(lev)%p,vname='p',netcdf_file_name=filen,rank=myrank)
        endif

        if(it>0)then
           conv=res0/res
           !           conv=log(res0/res)/log(10._8)
        else
           conv=0.
        endif
        res0=res
        if (myrank.eq.0)write(*,1000)"lev=",lev," - ite=",it," - res=",res," - conv=",conv
     enddo
     call cpu_time(tend)

  enddo
1000 format(A,I2,A,I5,A,G16.3,A,F8.3)

  if (myrank == 0) then
     rnpxg=real(grid(1)%npx,kind=rp)
     rnpyg=real(grid(1)%npy,kind=rp)
     rnxg=real(grid(1)%nx,kind=rp)*rnpxg
     rnyg=real(grid(1)%ny,kind=rp)*rnpyg
     rnzg=real(grid(1)%nz,kind=rp)
     ! the rescaled time should be expressed in terms of error reduction,
     ! therefore the ratio rnorm/rnorm0 [the rnorm0 was missing prior Dec 11th]
     perf = (tend-tstart)*(rnpxg*rnpyg)/(-log(res)/log(10._8))/(rnxg*rnyg*rnzg)
     write(*,*)'--- summary ---'
     write(*,'(A,F8.3,A)')"time spent to solve :",tend-tstart," s"
     write(*,'(A,E10.3)')"rescaled performance:",perf
     write(*,*)'---------------'
  end if

  call mpi_finalize(ierr)

  call toc(1,'mg_testrelax')
  if(myrank == 0) call print_tictoc(myrank)

end program mg_testrelax