C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 04.03.02.02/hueang                      *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE HUEANG (R,G,B, ANG, DIST)

C  This program calculates a characteristic angle for a hue from the
C  RGB color cube.  It does so by rotating the cube 45 deg around the
C  y-axis and atan(sqrt(2)) around the z-axis (assuming xyz = RGB).
C  This lines up the black-white cube diagonal (0,0,0 to 1,1,1) along
C  the y-axis.  Now, transformed points along the color-saturated
C  vertices are such that their angle in the x-z plane is a measure
C  of hue; so atan2 is used to compute the hue of any RGB point.

C  BTW, somewhat surprisingly, the points which are transformed into
C  the x=0 plane are all those in the old plane described by:
C  x -2y + z = 0 (this plane contains the points (0,0,0), (1,1,1),
C  and (0,.5,1), all of which can be "seen" to be rotated into x=0
C  plane).  This plane is such that it is satisfied by any points of
C  the form: (q, q+c, q+2c), so that sample points like (3,4,5) will
C  always transform into the x=0 plane.

C  Hueang also returns the distance of the RGB point from the
C  neutral (black-white) axis.

      REAL TMAT(4,4), R,G,B, XO,YO,ZO, PI,A45, ZZ,U, ANG, DIST

      ZZ = 0.0
      U = 1.0
      PI = 3.14159265
      A45 = PI/4.0

      CALL EBLTM3 (ZZ,ZZ,ZZ, ZZ,ZZ,ZZ, ZZ,A45,ATAN(SQRT(2.0)),
     1             U,U,U, TMAT)

10    CONTINUE

      CALL ETP3 (R,G,B, TMAT,  XO,YO,ZO)

      DIST = SQRT(XO*XO + ZO*ZO)

      IF (DIST .EQ. ZZ) THEN
         ANG = -666.0
      ELSE
C  Normalize to 0..1
         ANG = ATAN2(XO,ZO) / (2*PI)
         IF (ANG .LT. 0.0) ANG = ANG + 1
      ENDIF

      END

C  *********************************************************
C  *                                                       *
C  *    REAL FUNCTION 04.03.02.02/modsep                   *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      REAL FUNCTION MODSEP (PERIOD, A, B)

C  Given a period and two values, a and b, modsep calculates the
C  absolute value of the smallest "distance" between the values,
C  treating them as points on a circle with circumference of size =
C  period.  For example, if period=360, as for degree-measure,
C  modsep of 5 and 15 would of course be 10, but so would modsep of
C  5 and 355, or 0 and 710, or 0 and 730.

      REAL PERIOD, A, B, AM,BM, ABDIF

      IF (PERIOD .EQ. 0.0) THEN
         MODSEP = 0.0
         RETURN
      ENDIF

C get normalized mod-values - correct for loopy way Fortran
C mods negative numbers.
      AM = MOD (A,PERIOD)
      IF (A.LT.0) AM = AM+PERIOD
      BM = MOD (B,PERIOD)
      IF (B.LT.0) BM = BM+PERIOD
C now:   0 .le. am,bm  .lt. period

      ABDIF = ABS(AM-BM)
      MODSEP = MIN (ABDIF, PERIOD-ABDIF)

      END

C  *********************************************************
C  *                                                       *
C  *    LOGICAL FUNCTION 04.03.02.02/undcmd                *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      LOGICAL FUNCTION UNDCMD (NUMMOD,MODLIS,HICOL,PROMPT)

C  UNDCMD tests the list of color models passed in by requesting
C  dimensions and drawing color patches using those dimensions.
C  The operator is asked if the displayed color matches the
C  randomly chosen color coordinates.

C  Input parameters:
C    NUMMOD :  Size of list of color models
C    MODLIS :  Entire list of color models which may be tested
C    HICOL  :  Highest color index to be used
C    PROMPT :  String for prompt, indicating documentation to
C              be used for reference

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      COMMON /DIALOG/ DOUTYP, DINTYP, DSTDNR, DSTRID, PSTRID, DTCLIM,
     1                SCRMOD, DTXCI, SPECWT,
     2                DSIZE, EFRAC, DYXRAT, SYXRAT, MTRPDC, WCPDC, QVIS
      INTEGER         DOUTYP, DINTYP, DSTDNR, DSTRID, PSTRID, DTCLIM,
     1                SCRMOD, DTXCI, SPECWT
      REAL            DSIZE, EFRAC, DYXRAT, SYXRAT, MTRPDC, WCPDC, QVIS

C  interior style
      INTEGER    PHOLLO,   PSOLID,   PPATTR,   PHATCH,   PISEMP
      PARAMETER (PHOLLO=0, PSOLID=1, PPATTR=2, PHATCH=3, PISEMP=4)

C     type of returned values set, realized
      INTEGER    PSET,   PREALI
      PARAMETER (PSET=0, PREALI=1)

      INTEGER   CMDIM, NUMCM, COLIX, NUMCL, RANLIS(8), NUMTST
      INTEGER   CM, ICM, II, IX, ITRIM, POS1, NUMMOD, MODLIS(*), HICOL

      REAL      LO(8), HI(8), ACTCOL(8), COLARY(8)
      REAL      YLO,YHI, YTOP, YINCR, RNDRL

      CHARACTER CVAL*5, MSG*200, PROMPT*(*), RVALS*80

      LOGICAL   DYN, FILMOD, INTSTY, LOMAG

C  Determine how to fill in rectangles, use solid style
C  if it is available, otherwise use dense polyline cross-hatch
      FILMOD = INTSTY(SPECWT, PSOLID)
C  number of models to test
      NUMTST = MIN(8, NUMMOD)
C  Test a random subset of the models if > 8
      CALL RNSET (NUMTST,NUMMOD,RANLIS)

      DO 140 ICM = 1,NUMTST
         CALL PEMST (102)
C  Set Color Model
         CM = MODLIS(RANLIS(ICM))
         CALL PSCMD (WKID, CM)

         WRITE (CVAL, '(I5)') CM
         CALL DCHOIC ('DIMENSION OF COLOUR MODEL: How many '   //
     1                'dimensions are there for colour model ' //
     2                CVAL // '?', 0,100, CMDIM)

         IF (CMDIM .EQ. 0) THEN
            CALL INMSG ('Operator reported zero dimensions for a ' //
     1                  'color model.')
            UNDCMD = .FALSE.
            RETURN
         ENDIF

C  determine format for displaying color coordinates
         LOMAG = .TRUE.
         DO 100 IX = 1, CMDIM
            WRITE(CVAL, '(I5)') IX
            CALL DRLVAL('DIMENSION BOUNDS: Enter the LOWER limit ' //
     1                  'for valid values for dimension # '        //
     2                  CVAL, LO(IX))
            CALL DRLVAL('DIMENSION BOUNDS: Enter the UPPER limit ' //
     1                  'for valid values for dimension # '        //
     2                  CVAL, HI(IX))
            IF (ABS (LO(IX)) .GE. 10.0) LOMAG = .FALSE.
            IF (ABS (HI(IX)) .GE. 10.0) LOMAG = .FALSE.
100      CONTINUE

C  Draw color patches down left side of screen:
         NUMCM = HICOL - 1
         YINCR = 1.0 / (NUMCM + 1.0)
         YTOP  = 1 - YINCR
         YLO   = YTOP - 0.25*YINCR
         YHI   = YTOP + 0.25*YINCR
         CALL NUMLAB (NUMCM, 0.15, YTOP, YINCR)

         DO 130, COLIX = 2, HICOL
            DO 110 IX = 1, CMDIM
               COLARY(IX) = RNDRL(LO(IX),HI(IX))
110         CONTINUE

            CALL PSCR (WKID, COLIX, CMDIM, COLARY)
C  determine actual colval
            CALL PQCR (WKID,COLIX, CMDIM, PREALI, ERRIND, NUMCL,ACTCOL)
            CALL CHKINQ ('pqcr', ERRIND)

            IF (NUMCL .NE. CMDIM) THEN
               WRITE (MSG, '(A,I5,A,I5,A,I5,A)') 'Reported ' //
     1                'dimensionality for color model #', CM, ' is ',
     2                NUMCL, '; does not match value specified by ' //
     3                'operator = ', CMDIM, '.'
               CALL INMSG (MSG)
               UNDCMD = .FALSE.
               RETURN
            ENDIF

            CALL COLPCH (FILMOD, COLIX, 0.2, YLO, 0.5, YHI)
C  format color coordinates for printing
            RVALS = ' '
            DO 120 II = 1, NUMCL
               IF (LOMAG) THEN
                  POS1 = 6*II - 5
                  WRITE (RVALS(POS1:POS1+5), '(A,F5.2)') ',', ACTCOL(II)
               ELSE
                  POS1 = 10*II - 9
                  WRITE (RVALS(POS1:POS1+9), '(A,E9.2)') ',', ACTCOL(II)
               ENDIF
120         CONTINUE
            CALL VISLAB (RVALS(2:ITRIM(RVALS)), 'L', 0.55,0.95, YLO,YHI)

            YLO = YLO-YINCR
            YHI = YHI-YINCR

C  next random color within color model
130      CONTINUE

         WRITE (MSG, '(A,I5,A,A,A)') 'ACCURACY OF COLOUR MODEL: '  //
     1          'Are the colours of the rectangles compatible '    //
     2          'with the corresponding colour coordinate values ' //
     3          'within colour model #', CM, ', according to the ',
     4          PROMPT, '?'

         IF (DYN (MSG)) THEN
C           OK so far
         ELSE
            WRITE (CVAL, '(I5)') CM
            CALL INMSG ('Color Model #' // CVAL // ' caused failure.')
            UNDCMD = .FALSE.
            RETURN
         ENDIF
C  next color model
140   CONTINUE
      UNDCMD = .TRUE.

      END

C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 04.03.02.02/colpch                      *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE COLPCH (FILMOD, CLOR, XLO,YLO,XHI,YHI)

C  COLPCH will generate a rectangular color patch with the specified
C  diagonal vertices.  It will use solid interior fill area or
C  polylines based on the specified filling mode.

C  Input parameters:
C    FILMOD          : use fill area if true, otherwise polyline
C    CLOR            : color index to use
C    XLO,YLO,XHI,YHI : extent of the rectangle

      INTEGER    CLOR

      REAL       FILX(4), FILY(4), YINC, XLO,XHI,YLO,YHI, YVAL

      LOGICAL    FILMOD

C  interior style hollow, solid,    pattern,  hatch,    empty
      INTEGER   PHOLLO,   PSOLID,   PPATTR,   PHATCH,   PISEMP
      PARAMETER(PHOLLO=0, PSOLID=1, PPATTR=2, PHATCH=3, PISEMP=4)
C linetype
      INTEGER    PLSOLI,     PLDASH,     PLDOT,     PLDASD
      PARAMETER (PLSOLI = 1, PLDASH = 2, PLDOT = 3, PLDASD = 4)

      FILX(1) = XLO
      FILX(2) = XHI
      FILX(3) = XHI
      FILX(4) = XLO

      IF (FILMOD) THEN
         FILY(1) = YLO
         FILY(2) = YLO
         FILY(3) = YHI
         FILY(4) = YHI

         CALL PSIS  (PSOLID)
         CALL PSICI (CLOR)
         CALL PFA   (4, FILX,FILY)
      ELSE
         CALL PSLN   (PLSOLI)
         CALL PSPLCI (CLOR)
C  paint lines at the rate of about 400/screen
         YINC = 1.0/400
         DO 100 YVAL = YLO, YHI, YINC
           FILY(1) = YVAL
           FILY(2) = YVAL
           CALL PPL (2, FILX,FILY)
  100    CONTINUE
      ENDIF

      END

C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 04.03.02.02/coltrn                      *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE COLTRN (WKID, COLABL, FROMCC, FROMMD, TOCC, TOMD, SRS)

C  COLTRN tests the ability to translate color from one model to
C  another and issues pass or fail as a result.

C  Input parameters:
C    WKID   : workstation identifier
C    COLABL : labels (names) of colors to be tested
C    FROMCC : color coordinates to translate from
C    FROMMD : color model to translate from
C    TOCC   : color coordinates to translate to (expected result)
C    TOMD   : color model to translate to
C    SRS    : SR identifiers for test case

C colour model
      INTEGER    PRGB,   PCIE,   PHSV,   PHLS
      PARAMETER (PRGB=1, PCIE=2, PHSV=3, PHLS=4)

C type of returned value
      INTEGER    PSET,     PREALI
      PARAMETER (PSET = 0, PREALI = 1)

      INTEGER    WKID, FROMMD, TOMD, IX,IY, NUMRET, ERRIND, PASSCT

      REAL       FROMCC(3,9), TOCC(3,9), CSPEC(3),ACTCOL(3),EXPCOL(3)
      REAL       RNDRL

      LOGICAL    COLEQL

      CHARACTER  MSG*300, SRS*(*), MODNAM(PRGB:PHLS)*3, COLABL(9)*8

      DATA  MODNAM  / 'RGB', 'CIE', 'HSV', 'HLS' /

      PASSCT = 0
      DO 100 IX = 1,9
C <set colour model>
         CALL PSCMD (WKID, FROMMD)
C  <set colour representation> index #1, entry #ix, change -1 to
C     random value between 0 and 1
         DO 110 IY = 1,3
            IF (FROMCC(IY,IX) .EQ. -1) THEN
               CSPEC(IY) = RNDRL (0., 1.)
            ELSE
               CSPEC(IY) = FROMCC(IY,IX)
            ENDIF
            EXPCOL(IY) = TOCC(IY,IX)
110      CONTINUE
         CALL PSCR (WKID, 1, 3, CSPEC)
         CALL PQCR (WKID, 1, 3, PREALI, ERRIND, NUMRET, ACTCOL)
         CALL CHKINQ ('pqcr', ERRIND)
C  attempt to convert only realizable colors
         IF (.NOT. COLEQL (3, ACTCOL, CSPEC, 0.02, 0.0)) GOTO 100

C  <re-set colour model>
         CALL PSCMD (WKID, TOMD)
C  <inquire colour representation> as SET, to determine cspec
         CALL PQCR (WKID, 1, 3, PSET, ERRIND, NUMRET, ACTCOL)
         CALL CHKINQ ('pqcr', ERRIND)

         IF (NUMRET.EQ.3 .AND.
     1       COLEQL (3, ACTCOL, EXPCOL, 0.1, 0.0)) THEN
C  OK so far
            PASSCT = PASSCT+1
         ELSE
            PASSCT = -666
            WRITE (MSG, '(A)') 'Fail to change colour model from ' //
     1             MODNAM(FROMMD) // ' to ' // MODNAM(TOMD) //
     2             ' for colour = ' // COLABL(IX) // '.'
            CALL INMSG (MSG)
         ENDIF
100   CONTINUE

      IF (PASSCT .EQ. 0) THEN
         CALL INMSG ('No realizable ' // MODNAM(FROMMD) //
     1               ' colors for ' // MODNAM(FROMMD) // ' to ' //
     2               MODNAM(TOMD) // ' conversion test.')
      ELSE
         CALL SETMSG (SRS, 'Changing the colour model from '   //
     1                MODNAM(FROMMD) // ' to ' // MODNAM(TOMD) //
     2                ' should not affect the colours in the ' //
     3                'colour table.')
         CALL IFPF (PASSCT .GT. 0)
      ENDIF

      END

C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 04.03.02.02/sethue                      *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE SETHUE (WKID,COLMOD,MAXFG,PALTTE,CC, NUMSET,LSCOLI)

C  SETHUE tries to set as many hues as possible in the color table
C  and reports back the order in which they were set and how many.
C
C  Input parameters
C    WKID   : workstation identifier
C    COLMOD : Color model to set up under
C    MAXFG  : Maximum number of available foreground entries in
C             color table, starting with #2
C    PALTTE : Number of colors to be displayed if possible
C    CC     : Color coordinates to be set in color table
C
C  Output parameters
C    NUMSET : Number of entries successfully set
C    LSCOLI : List of which entries in CC (palette) were set

C type of returned value
      INTEGER    PSET,     PREALI
      PARAMETER (PSET = 0, PREALI = 1)
C colour model
      INTEGER    PRGB,     PCIE,     PHSV,     PHLS
      PARAMETER (PRGB = 1, PCIE = 2, PHSV = 3, PHLS = 4)

      INTEGER   COLMOD, MAXFG, PALTTE, NUMSET, LSCOLI(*)
      INTEGER   RNCOL(20), IX, IY, ERRIND, CCSIZ, WKID, NUMDSP, PALIX

      REAL      CC(3,PALTTE), THISCC(3), REALCC(3), RNDRL

      LOGICAL   COLEQL, COLOK

      CALL PSCMD (WKID, COLMOD)

C  max number to be displayed
      NUMDSP = MIN(MAXFG, PALTTE)
      CALL RNSET (NUMDSP, PALTTE, RNCOL)

C  how many set so far?
      NUMSET = 0
      DO 100 IX = 1,NUMDSP
C  which color in palette to try
         PALIX = RNCOL(IX)
         DO 110 IY = 1,3
            THISCC(IY) = CC(IY, PALIX)
C  treat -1 as a "don't care" value
            IF (THISCC(IY) .EQ. -1) THISCC(IY) = RNDRL (0.,1.)
110      CONTINUE
         CALL PSCR (WKID, NUMSET+2, 3, THISCC)
         CALL PQCR (WKID, NUMSET+2, 3, PREALI, ERRIND, CCSIZ, REALCC)
         CALL CHKINQ ('pqcr', ERRIND)
         IF (CCSIZ .NE. 3) GOTO 100
C  is realized hue close enough ??
         IF (COLMOD .EQ. PCIE) THEN
            COLOK = COLEQL(2, REALCC,    THISCC,    0.01, 0.0) .AND.
     1              COLEQL(1, REALCC(3), THISCC(3), 0.1,  0.0)
         ELSE
            COLOK = COLEQL(3, REALCC, THISCC, 0.05, 0.0)
         ENDIF

         IF (COLOK) THEN
C  add to list
            NUMSET = NUMSET+1
            LSCOLI(NUMSET) = PALIX
         ELSE
C           not set
         ENDIF
100   CONTINUE

      END

C  *********************************************************
C  *                                                       *
C  *    INTEGER FUNCTION 04.03.02.02/tsthue                *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      INTEGER FUNCTION TSTHUE (PRMPT, FILMOD, NUMSET, LSCOLI)

C  TSTHUE displays NUMSET colors, starting with #2, using LSCOLI as
C  color indices.  It then asks the operator to identify these and
C  issues 1 (pass), -1 (fail), or -2 (fail with comment), as a result.
C
C  Input parameters:
C    PRMPT  : prompt for the operator
C    FILMOD : fill mode for rectangle; true for solid fill area,
C             false for polylines
C    NUMSET : number of colored rectangles to be drawn
C    LSCOLI : list of identifiers from color palette

      INTEGER   NUMSET, LSCOLI(*), IX, ANSSIZ, ANSLIS(20)

      REAL      YTOP, YINCR, YVAL

      LOGICAL   FILMOD, IAREQL

      CHARACTER PRMPT*(*)

      YINCR = 1.0 /(NUMSET+1)
      YTOP  = 1-YINCR
      YVAL  = YTOP - 0.25*YINCR

      DO 120 IX = 1,NUMSET
         CALL COLPCH (FILMOD, IX+1, .25,YVAL, .75,YVAL + 0.5*YINCR)
         CALL PSPLCI (1)
         CALL DRWREC (.25,.75, YVAL,YVAL + 0.5*YINCR)
         YVAL = YVAL-YINCR
120   CONTINUE

      CALL DILIST (PRMPT, ANSSIZ, ANSLIS)
      IF (ANSSIZ.EQ.1 .AND. ANSLIS(1).EQ.0) THEN
         TSTHUE = -2
      ELSEIF (IAREQL (ANSSIZ,ANSLIS, NUMSET,LSCOLI)) THEN
         TSTHUE = 1
      ELSE
         TSTHUE = -1
      ENDIF

      CALL PEMST (102)

      END

C  *********************************************************
C  *                                                       *
C  *    LOGICAL FUNCTION 04.03.02.02/coleql                *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      LOGICAL FUNCTION COLEQL (SIZE, ACT,EXP, ABSERR,RELERR)

C  Special purpose routine for testing approximate equality of
C  all three color components, unless one is -1.

C  Input parameters:
C    SIZE    : Number of elements to be compared
C    ACT     : actual values
C    EXP     : expected values
C    ABSERR  : absolute tolerance
C    RELERR  : relative tolerance

      INTEGER  SIZE, IX
      REAL     ACT(SIZE), EXP(SIZE), ABSERR, RELERR
      LOGICAL  APPEQ

      DO 100 IX = 1,SIZE
         IF (ACT(IX) .EQ. -1 .OR. EXP(IX) .EQ. -1) THEN
C OK so far
         ELSEIF (APPEQ (ACT(IX), EXP(IX), ABSERR, RELERR)) THEN
C OK so far
         ELSE
            COLEQL = .FALSE.
            RETURN
         ENDIF
100   CONTINUE
      COLEQL = .TRUE.

      END


program poisson
!----------------------------------------------------------------------
        ! This parallel code solves for the 2D Laplace equation
        ! using 1D decomposition
!----------------------------------------------------------------------

        implicit none
        include 'mpif.h'

        !-----------Define the parameters, variables---------

        integer :: nprocs, rank, ierr, np
        integer, parameter :: m = 250, n = 250, max_iter = 10000
        real(kind = 8), parameter ::  tol = 1.e-5
        real(kind = 8) :: t0, t1, t2, diff, max_val
        real(kind = 8), dimension(:,:), allocatable :: aloc
        integer, dimension(:), allocatable :: jbeg, jend
        integer :: istat(MPI_STATUS_SIZE)
        logical :: converged
        integer :: i
        !----------------------------------------------------

        call MPI_INIT(ierr)
        t0 = MPI_WTIME()

        call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr)
        call MPI_COMM_SIZE(MPI_COMM_WORLD, nprocs, ierr)

        np = n/nprocs + 1 ! Maximum length of the local array on any proc
        allocate(aloc(0:m+1,0:np+1))
        allocate(jbeg(0:nprocs-1))
        allocate(jend(0:nprocs-1))

        ! Print the welcome statement
        print *, 'I am P:',rank,'out of',nprocs
        call decompose(n, nprocs, jbeg, jend)

        !Set the boundary conditions
        call bc(aloc, 1, m, jbeg(rank), jend(rank), m, n, rank, nprocs)

        !Communication across the ghost cells
        call comm(m, nprocs, jbeg(rank), jend(rank), aloc, rank)

        t1 = MPI_WTIME()
        !Start the time loop
        do i = 1, max_iter
                call jacobi_step(m, n, 1, m, jbeg(rank), jend(rank), nprocs, rank, aloc, &
                       diff, max_val)

                !Check for convergence of the solution
                if (converged(diff, max_val, tol, rank)) then
                        exit
                end if

                !Exchange the ghost cell data
                call comm(m, nprocs, jbeg(rank), jend(rank), aloc, rank)
        end do
        t2 = MPI_WTIME()
        call write_result(rank, nprocs, aloc, jbeg, jend, jbeg(rank), jend(rank), m)

        print *, 'The time taken for the computation is:', t2 - t1

        call MPI_FINALIZE(ierr)

        deallocate(aloc)
        deallocate(jbeg)
        deallocate(jend)

end program

!----------------------------------------------------------------------
        !Subroutine for decomposing the domain
!----------------------------------------------------------------------

subroutine decompose(n, nprocs, jbeg, jend)
        implicit none

        integer, intent(in) :: n, nprocs
        integer, dimension(0:nprocs-1), intent(out) :: jbeg, jend
        integer :: loc_size, i

        loc_size = n/nprocs
        do i = 0, nprocs-1

                jbeg(i) = i*loc_size + 1
                jend(i) = jbeg(i) + loc_size - 1

        end do

        if (mod(n, nprocs).ne.0) then
                jend(nprocs-1) = jend(nprocs-1) + mod(n, nprocs)
        end if

end subroutine

!----------------------------------------------------------------------
        !Assigning the values for the boundary_condition
!----------------------------------------------------------------------

subroutine bc(a, ifirst, ilast, jfirst, jlast, m, n, rank, nprocs)

        implicit none
        real(kind = 8), dimension(ifirst-1:ilast+1, jfirst-1:jfirst+1) :: a
        integer :: ifirst, ilast, jfirst, jlast, i, j, m, n, rank, nprocs
        real(kind = 8) :: x, y, boundary_func

        !setting all the values to zero
        do i = ifirst-1, ilast + 1
                do j = jfirst -1, jfirst + 1
                       a(i,j) = 0.d0
                end do
        end do

        !Filling the i-constant boundary values
        !Keeping the values at the ghost cells as zero

        i = ifirst - 1
        x = dble(i)/dble(m+1)
        do j = jfirst, jlast
                y = dble(j)/dble(n+1)
                a(i,j) = boundary_func(x,y)
        end do
        i = ifirst + 1
        x = dble(i)/dble(m+1)
        do j = jfirst, jlast
                y = dble(j)/dble(n+1)
                a(i,j) = boundary_func(x,y)
        end do

        !Filling the j-constant boundary values
        if (rank.eq.0) then
                j = jfirst-1
                y = dble(j)/dble(n+1)
                do i = ifirst-1, ilast+1
                        x = dble(i)/dble(m+1)
                        a(i,j) = boundary_func(x,y)
                end do
        end if
        if (rank.eq.nprocs-1) then
                j = jlast + 1
                y = dble(j)/dble(n+1)
                do i = ifirst - 1, ilast + 1
                        x = dble(i)/dble(m+1)
                        a(i,j) = boundary_func(x,y)
                end do
        end if

end subroutine

!----------------------------------------------------------------------------
        !Function for setting the boundary condition
!----------------------------------------------------------------------------
function boundary_func(x,y)
        implicit none
        real(kind = 8) :: boundary_func, x, y, pi
        pi = 4.d0*atan(1.d0)
        boundary_func = sin(pi*x)*exp(-pi*y)
end function

!----------------------------------------------------------------------------
        !Subroutine for communicating the ghost cell values
!----------------------------------------------------------------------------
subroutine comm(m, nprocs, jfirst, jlast, a, my_rank)
        implicit none
        include 'mpif.h'

        integer :: jfirst, jlast, m, nprocs, ierr, my_rank, idest, iorigin
        real(kind=8), dimension(0:m+1, jfirst-1:jlast+1) :: a
        integer, parameter :: nmsg = 2
        integer :: istat(MPI_STATUS_SIZE, 2*nmsg), nreq, i, j, tag
        integer, dimension(nmsg) :: iseq_send, iseq_recv
        integer, dimension(2*nmsg) :: ireq

        iseq_recv  = (/-1, +1/)
        iseq_send = (/+1, -1/)

        nreq = 0
        tag = 5

        do i = 1, nmsg

                !Sending to the destination (non-blocking)
                idest = my_rank + iseq_send(i)
                if (idest.ge.0.and.idest.le.nprocs-1) then
                        if (iseq_send(i).eq.+1) then
                                j = jlast
                        else
                                j = jfirst
                        end if

                nreq = nreq + 1
                call MPI_ISEND(a(0,j), m+2, MPI_DOUBLE_PRECISION, idest,tag, &
                                MPI_COMM_WORLD, ireq(nreq), ierr)
                end if

                !Receiving from the origin (non-blocking)
                iorigin = my_rank + iseq_recv(i)
                if (iorigin.ge.0.and.iorigin.le.nprocs-1) then
                        if(iseq_recv(i).eq.+1) then
                                j = jlast + 1
                        else
                                j = jfirst - 1
                        end if
                nreq = nreq + 1
                call MPI_IRECV(a(0,j), m+2, MPI_DOUBLE_PRECISION, iorigin, &
                               tag, MPI_COMM_WORLD, ireq(nreq), ierr)
                end if
        end do

        ! Wait for the non-blocking communications to end
        call MPI_WAITALL(nreq, ireq, istat, ierr)

end subroutine

!------------------------------------------------------------------------------
        !Doing the jacobi step
!------------------------------------------------------------------------------
subroutine jacobi_step(m, n, ifirst, ilast, jfirst, jlast, nprocs, my_rank, a, &
                       diff, max_val)
        implicit none
        integer :: m, n, ifirst, ilast, jfirst, jlast, nprocs, my_rank
        real(kind=8) :: diff, dx, dy, max_val
        real(kind=8), dimension(ifirst-1:ilast+1, jfirst-1:jlast+1) :: a, tmp
        integer :: i, j

        dx = 1.d0/(m + 1)
        dy = 1.d0/(n + 1)
        diff = 0.d0
        max_val = 0.d0

        !Update step
        do j = jfirst, jlast
                do i = ifirst, ilast
                        tmp(i,j) = 0.25*(a(i,j+1) + a(i-1,j) + a(i,j+1) + a(i, j-1))
                        diff = max(diff, abs(tmp(i,j) - a(i,j)))
                        max_val = max(max_val, tmp(i,j))
                end do
        end do

        do j = jfirst, jlast
                do i = ifirst, ilast
                        a(i,j) = tmp(i,j)
                end do
        end do

end subroutine

!--------------------------------------------------------------------------------------
        !Subroutine for checking convergence
!--------------------------------------------------------------------------------------

logical function converged(diffl, max_vall, tol, my_rank)
        implicit none
        include 'mpif.h'

        real(kind=8) :: diffl, diffg, max_vall, max_valg, tol
        integer :: iter, my_rank, ierr
        !logical :: converged

        converged = .false.

        call MPI_ALLREDUCE(diffl, diffg, 1, MPI_DOUBLE_PRECISION, MPI_MAX, &
                            MPI_COMM_WORLD, ierr)

        call MPI_ALLREDUCE(max_vall, max_valg, 1, MPI_DOUBLE_PRECISION, MPI_MAX, &
                           MPI_COMM_WORLD, ierr)

        diffg = diffg/max_valg
        if (diffg.le.tol) then
                converged = .true.
                write(*,*) 'P:',my_rank,'has converged'
        end if
end function

!---------------------------------------------------------------------------------------
        !Subroutine to collect the local values from the processors and initiating
        !a write to a file
!---------------------------------------------------------------------------------------
subroutine write_result(rank, nprocs, a, jbeg, jend, jfirst, jlast, m)
        implicit none
        include "mpif.h"

        integer :: rank, nprocs, iproc, jfirst, jlast, i, j, jff, jll, m
        real(kind=8), dimension(0:m+1, jfirst-1:jlast+1) :: a, temp
        integer :: ierr, istat(MPI_STATUS_SIZE)
        integer, dimension(0:nprocs-1) :: jbeg, jend

        open(10, file = "result.dat", status = "new")
                if(rank.eq.0) then
                        jll = jlast
                        if(nprocs.eq.1) jll = jlast + 1
                        do j = jfirst-1, jll
                                do i = 0, m+1
                                        write(10, 20) i, j, a(i,j)
                                        !format(I10, I10, F15.8)
                                end do
                        end do

                        do iproc = 1, nprocs-1
                                call MPI_RECV(temp, (jend(iproc) - jbeg(iproc) + 3)*(m+2), &
                                              MPI_DOUBLE_PRECISION, iproc, 1, MPI_COMM_WORLD, &
                                              istat, ierr)
                                jll = jend(iproc)
                                if(iproc.eq.nprocs-1) then
                                        jll = jend(iproc) + 1
                                end if
                                do j = jfirst, jll
                                        do i = 0, m+1
                                                write(10, 20) i, j, temp(i,j)
                                                20 format(I10, I10, F15.8)
                                        end do
                                end do
                        end do

                else
                        call MPI_SEND(a, (jend(rank) - jbeg(rank) + 3)*(m+2), &
                                      MPI_DOUBLE_PRECISION, 0, 1, MPI_COMM_WORLD, &
                                      ierr)
                end if

        close(10)
        call MPI_BARRIER(MPI_COMM_WORLD, ierr)
end subroutine


program iso_kinds
use iso_fortran_env, only: real32,real64,real128,int8,int16,int32, &
                           int64,integer_kinds,real_kinds
implicit none
real(real32)   :: x32
real(real64)   :: x64
real(real128)  :: x128
integer(int8)  :: i8
integer(int16) :: i16
integer(int32) :: i32
integer(int64) :: i64
! negative values for real32, real64, real128 mean they are unsupported
print "('real32, real64, real128:',*(1x,i0))",real32,real64,real128
! real_kinds and integer_kinds are a Fortran 2008 feature.
print "('real_kinds:',*(1x,i0))",real_kinds ! available real kinds
print "(/,'int8, int16, int32, int64:',*(1x,i0))",int8,int16,int32,int64
print "('integer_kinds:',*(1x,i0))",integer_kinds ! available integer kinds
print "(/,'huge() for integer types')"
print "(' int8',1x,i0)",huge(i8)
print "('int16',1x,i0)",huge(i16)
print "('int32',1x,i0)",huge(i32)
print "('int64',1x,i0)",huge(i64)
print "(/,'huge() for real types')"
print*," real32",huge(x32)
print*," real64",huge(x64)
print*,"real128",huge(x128)
print "(/,'tiny() for real types')"
print*," real32",tiny(x32)
print*," real64",tiny(x64)
print*,"real128",tiny(x128)
end program iso_kinds
! output for gfortran.
! real32, real64, real128: 4 8 16
! real_kinds: 4 8 10 16
!
! int8, int16, int32, int64: 1 2 4 8
! integer_kinds: 1 2 4 8 16
!
! results up to here may differ by compiler
!
! huge() for integer types
!  int8 127
! int16 32767
! int32 2147483647
! int64 9223372036854775807
!
! huge() for real types
!   real32   3.40282347E+38
!   real64   1.7976931348623157E+308
!  real128   1.18973149535723176508575932662800702E+4932
!
! tiny() for real types
!   real32   1.17549435E-38
!   real64   2.2250738585072014E-308
!  real128   3.36210314311209350626267781732175260E-4932


module tau_aL

  implicit none

  interface
    subroutine RC3JJ(l1, l2, m1, m2, l3min, l3max, wig, ndim, ier)
      real(4), intent(in)  :: l1, l2, m1, m2
      real(4), intent(out) :: l3min, l3max
      integer, intent(in) :: ndim
      real(4), dimension(*), intent(out) :: wig
      integer :: ier
    end subroutine RC3JJ
 end interface

contains

  subroutine get_AL_tau(cltt, nltt, lmax, AL)
    integer, parameter  :: dp = 4
    integer, intent(in) :: lmax
    real(dp), intent(in), dimension(0:lmax)  :: cltt
    real(dp), intent(in), dimension(0:lmax)  :: nltt
    real(dp), intent(out), dimension(0:lmax) :: AL

    real(dp), parameter  :: one_fourpi = 1.d0 / (atan(1.) * 16.d0)
    integer :: l1, l2, l3min, l3max, dim, ier, l, lwig
    real(dp) :: rl1, rl2, rl3min, rl3max, numb
    real(dp), dimension(0:2*lmax) :: wigner
    real(dp), dimension(0:lmax)   :: ell

    wigner = 0.

    ell = [(l, l=0, lmax)]

    do l1=0, lmax
      rl1 = real(l1, kind=dp)
      numb = 0.
       do l2=0, lmax

          fact = (2 * ell(l1) + 1) * (2 * ell(l2) + 1) / (16. * 3.1415)
          fact = fact * cltt(l1) * cltt(l1)
          fact = fact / (cltt(l1) + nltt(l1))
          fact = fact / (cltt(l2) + nltt(l2))

          rl2 = real(l2, kind=dp)
          dim = l1 + l2 + 1
          call RC3JJ(rl1, rl2, 0., 0., rl3min, rl3max, wigner, dim, ier)
          if (ier .ne. 0) then
             write(*,*), '!!! ERROR -- Wigner 3J !!!', ier
             stop
          endif
          l3min = int(rl3min)
          l3max = min(int(rl3max), lmax)

          do l = l3min, l3max
             lwig = l - l3min
             numb = numb  +  wigner(lwig) * wigner(lwig)
          enddo

          numb = numb * fact

       enddo
    enddo

  end subroutine get_AL_tau

end module tau_aL


c     =====================================================
       subroutine qinit(maxmx,maxmy,meqn,mbc,mx,my,xlower,ylower,
     &                   dx,dy,q,maux,aux)
c     =====================================================
c
c      # Set initial sea level flat unless iqinit = 1, in which case
c      # an initial perturbation of the q(i,j,1) is specified and has
c      # been strored in qinitwork.

       use geoclaw_module

       implicit double precision (a-h,o-z)
       dimension q(1-mbc:maxmx+mbc, 1-mbc:maxmy+mbc, meqn)
       dimension aux(1-mbc:maxmx+mbc,1-mbc:maxmy+mbc,maux)

c      include 'qinit.i'

c      grav = 9.81d0   !# should come from module
       a = 1.d0
       sigma = 0.5d0
       h0 = 0.1d0
       omega = dsqrt(2.d0*grav*h0) / a
       write(6,*) 'omega = ',omega

       do i=1-mbc,mx+mbc
          x = xlower + (i-0.5d0)*dx
          do j=1-mbc,my+mbc
             y = ylower + (j-0.5d0)*dy
             eta = sigma*h0/a**2 * (2.*x - sigma)
             q(i,j,1) = dmax1(0.d0,eta-aux(i,j,1))
             q(i,j,2) = 0.d0
             q(i,j,3) = sigma*omega * q(i,j,1)
             enddo
          enddo

       return
       end


subroutine evolve_radius(j,t)
!****************************************************************
! Evolve radius of embryo j at time t
! Currently assumes a polytropic collapse (cf protostar formation)
!****************************************************************

use eosdata,only: pi
use embryodata

implicit none

integer, intent(in) :: j
real, intent(in) :: t
real :: rchoose

IF(embryo(j)%itidal==0) rchoose = embryo(j)%R0
IF(embryo(j)%itidal==1) rchoose = embryo(j)%R

embryo(j)%R = rchoose/(1.0 + 2.0*t/embryo(j)%t_cool0)**0.5
embryo(j)%rhoc = embryo(j)%M/(4.0*pi*theta_grad*embryo(j)%R**3)

end subroutine evolve_radius


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

      MODULE m_od_cylbes
      use m_juDFT
      CONTAINS
      SUBROUTINE od_cylbes(
     >     m1,x,
     <     fJ)

      IMPLICIT NONE
!     ..
!     ..Arguments ..
      INTEGER, INTENT  (IN) :: m1
      REAL,    INTENT  (IN) :: x
      REAL,    INTENT (OUT) :: fJ
!
!     .. Parameters ..
      REAL,    PARAMETER :: zero = 0.0
!     ..Locals ..
      INTEGER :: m,i,mass
      REAL :: quot
      REAL, ALLOCATABLE :: aux(:)
!     ..

      IF (x.LT.zero)  CALL juDFT_error("cylbes2",calledby="od_cylbes")

      IF (x.EQ.zero .AND. m1.EQ.0) THEN
         fJ = 1.
         RETURN
      END IF
      IF (x.EQ.zero .AND. m1.NE.0) THEN
         fJ = 0.
         RETURN
      END IF

      if (m1.lt.0) then
         m = -m1
      else
         m = m1
      end if

      mass = INT( m + 50 + x )
      ALLOCATE ( aux(0:mass) )
      aux(mass) = 0.0
      aux(mass-1) = 1.0e-22

      DO i=mass-2,0,-1
        aux(i) = 2*(i+1)*aux(i+1)/x - aux(i+2)
      END DO

      quot = aux(0)

      DO i=1,INT( mass/2. )
        quot = quot + 2*aux(2*i)
      END DO

      IF (m1.LT.0) THEN
         fJ = ((-1)**m)*aux(m)/quot
      ELSE
         fJ = aux(m)/quot
      END IF

      DEALLOCATE ( aux )

      RETURN
      END SUBROUTINE od_cylbes
      END MODULE m_od_cylbes


*DECK DCSEVL
      DOUBLE PRECISION FUNCTION DCSEVL (X, CS, N)
C***BEGIN PROLOGUE  DCSEVL
C***PURPOSE  Evaluate a Chebyshev series.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C3A2
C***TYPE      DOUBLE PRECISION (CSEVL-S, DCSEVL-D)
C***KEYWORDS  CHEBYSHEV SERIES, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C  Evaluate the N-term Chebyshev series CS at X.  Adapted from
C  a method presented in the paper by Broucke referenced below.
C
C       Input Arguments --
C  X    value at which the series is to be evaluated.
C  CS   array of N terms of a Chebyshev series.  In evaluating
C       CS, only half the first coefficient is summed.
C  N    number of terms in array CS.
C
C***REFERENCES  R. Broucke, Ten subroutines for the manipulation of
C                 Chebyshev series, Algorithm 446, Communications of
C                 the A.C.M. 16, (1973) pp. 254-256.
C               L. Fox and I. B. Parker, Chebyshev Polynomials in
C                 Numerical Analysis, Oxford University Press, 1968,
C                 page 56.
C***ROUTINES CALLED  D1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900329  Prologued revised extensively and code rewritten to allow
C           X to be slightly outside interval (-1,+1).  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DCSEVL
      DOUBLE PRECISION B0, B1, B2, CS(*), ONEPL, TWOX, X, D1MACH
      LOGICAL FIRST
      SAVE FIRST, ONEPL
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DCSEVL
      IF (FIRST) ONEPL = 1.0D0 + D1MACH(4)
      FIRST = .FALSE.
      IF (N .LT. 1) CALL XERMSG ('SLATEC', 'DCSEVL',
     +   'NUMBER OF TERMS .LE. 0', 2, 2)
      IF (N .GT. 1000) CALL XERMSG ('SLATEC', 'DCSEVL',
     +   'NUMBER OF TERMS .GT. 1000', 3, 2)
      IF (ABS(X) .GT. ONEPL) CALL XERMSG ('SLATEC', 'DCSEVL',
     +   'X OUTSIDE THE INTERVAL (-1,+1)', 1, 1)
C
      B1 = 0.0D0
      B0 = 0.0D0
      TWOX = 2.0D0*X
      DO 10 I = 1,N
         B2 = B1
         B1 = B0
         NI = N + 1 - I
         B0 = TWOX*B1 - B2 + CS(NI)
   10 CONTINUE
C
      DCSEVL = 0.5D0*(B0-B2)
C
      RETURN
      END


      SUBROUTINE chint(a,b,c,cint,n)
      INTEGER n
      REAL a,b,c(n),cint(n)
      INTEGER j
      REAL con,fac,sum
      con=0.25*(b-a)
      sum=0.
      fac=1.
      do 11 j=2,n-1
        cint(j)=con*(c(j-1)-c(j+1))/(j-1)
        sum=sum+fac*cint(j)
        fac=-fac
11    continue
      cint(n)=con*c(n-1)/(n-1)
      sum=sum+fac*cint(n)
      cint(1)=2.*sum
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/chint.for


program problem7
  use euler
  implicit none
  integer*8 :: i=0
  integer   :: found=0,limit=10001

  do while (found < limit)
     i=i+1
     if (is_prime(i)) then
        found=found+1
     end if
  end do

  print *, i

end program problem7


PROGRAM Task1
IMPLICIT NONE

INTEGER, PARAMETER:: n=80
INTEGER:: i, j, it
REAL:: Epsilon0, EpsilonRH, KBoltz, CSalt, e, Kappa, OldVal, X, Y
REAL:: Phi(-n:n, -n:n), h, tol

Epsilon0=8.85E-12; EpsilonRH=80; KBoltz = 1.38-E13; h=0.05; tol=1.0E-5; Phi = 0.0; CSalt=3E26

!Kappa = SQRT((2.0*CSalt)*e**2.0)/(Epsilon0*EpsilonRH*KBoltz)
Kappa=1.0
WRITE(6,*) Kappa
Kappa = Kappa/1.0E9

WRITE(6,*) 1.0/Kappa

DO i=-n,n
  DO j = -n, n
    X = REAL(i)*h; Y = REAL(j)*h
    IF ((X**2.0+Y**2.0) <= 1.0**(2.0+tol)) THEN
      PHI(i,j) = 100.0
    END IF
  END DO
END DO

DO it = 1, 100000
  DO i = -n+1,n-1
    DO j = -n+1, n-1
      X=REAL(i)*h; Y=REAL(j)*h; OldVal = Phi(i,j)
      IF ((X**2.0+Y**2.0) <= 1.0**(2.0+tol)) THEN
        !We are inside the cylinder
			ELSE
        Phi(i,j) = (Phi(i-1, j)+Phi(i,j+1)+Phi(i,j+1)+Phi(i,j-1))/(4.0+h**2.0+Kappa**2.0)
			END IF

	  END DO
  END DO
END DO

OPEN(1, FILE = 'Results.dat')
DO i = -n,n
  DO j = -n,n
    WRITE(1,'(f4.2, f4.2, f7.4)') REAL(i)*h, REAL(j)*h, Phi(i,j)
  END DO
END DO

 END PROGRAM


!> Parameters to be used during calculations
!! such as conversion factors, imaginary number, \f$ \pi \f$....
MODULE parameters
  USE kinds
  IMPLICIT NONE

  REAL(dp), PARAMETER :: pi=4.0_dp*DATAN(1.0_dp),    & !4.0d0*atan(1.d0),
       kb=1.3806488e-23_dp,                      & ! Boltzmann constant J/K
       planck=6.626068e-34_dp,                   & ! Planck's constant in Js
       hbar=planck/2.0_dp/pi,                   & ! hbar in Js
       avog = 6.0221415e23_dp,                   & ! Avogadro's number
       light = 2.99792458e10_dp,                 & ! Speed of light (SI) in cm/s
       ! *************** ENERGY *************** !
       joules2wvnbr = 1.0_dp/planck/light,      & ! Joules (SI) to wavenumber
       wvnbr2joules = 1.0_dp/joules2wvnbr,      & ! wavenumber to Joules
       ! **************** LENGTH ************** !
       m2ang = 1.e10_dp,                         & ! meter to Angstrom
       ang2m = 1.0_dp/m2ang,                    & ! Angstrom to meter
       ! ***************** RMASS *************** !
       amu2kg = 1.66053892e-27_dp,               & ! atomic rmass unit to kg
       ! ************** TIME ****************** !
       s2ps = 1.0e12_dp,                          & ! seconds to picoseconds
       ps2s = 1.0_dp/s2ps,                      & ! picoseconds to seconds
       s2fs = 1.0e15_dp,                          & ! seconds to femtoseconds
       fs2s = 1.0_dp/s2fs,                      & ! femtoseconds to seconds
       ! ************** FREQUENCY ************* !
       wvnbr2Hz = light,                      & ! wavenumbers to Hertz
       Hz2wvnbr = 1.0_dp/wvnbr2Hz,              & ! Hertz to wavenumbers
       ! ***************** 2 a.u. ************* !
       au2joules = 4.35974417e-18_dp,            & ! a.u. energy to Joules
       joules2au = 1.0_dp/au2joules,            & ! Joules to a.u. energy
       ev2au=0.03674932_dp,                    & ! eV to a.u. energy
       au2ev=1.0_dp/ev2au,                      & ! a.u. energy to eV
       autime2s = 2.418884326505e-17_dp,         & ! a.u. time to seconds
       s2autime = 1.0_dp/autime2s,              & ! seconds to a.u. time
       autemp2K = 3.1577464e5_dp,                & ! a.u. temperature to Kelvin
       K2autemp = 1.0_dp/autemp2K,              & ! Kelvin to a.u. temperature
       au2ang = 0.52917725_dp,                 & ! atomic length to Angstrom
       ang2au = 1.0_dp/au2ang                    ! Angstrom to atomic length

  COMPLEX(dp), PARAMETER :: eye=(0.0_dp, 1.0_dp)

END MODULE parameters


!##############################################################################
!# Tutorial 023a: Calculate an L2 and H1 norm with the block integration
!##############################################################################

module tutorial023a

  ! Include basic Feat-2 modules
  use fsystem
  use storage
  use genoutput

  use triangulation
  use meshgeneration

  use element
  use cubature
  use spatialdiscretisation
  use linearsystemscalar
  use linearsystemblock
  use bilinearformevaluation

  use feevaluation2
  use blockmatassemblybase
  use blockmatassembly
  use blockmatassemblystdop

  implicit none
  private

  public :: start_tutorial023a

contains

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

  subroutine start_tutorial023a

    ! Declare some variables.
    type(t_triangulation) :: rtriangulation
    type(t_spatialDiscretisation) :: rspatialDiscr
    type(t_blockDiscretisation) :: rblockDiscr
    type(t_scalarCubatureInfo), target :: rcubatureInfo
    type(t_vectorBlock) :: rx
    type(t_fev2Vectors) :: rcoeffVectors

    integer :: ivt
    real(DP) :: dx, dintvalue
    real(DP), dimension(:,:), pointer :: p_DvertexCoords
    real(DP), dimension(:), pointer :: p_Ddata

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 023a")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Create a brick mesh
    ! =================================

    ! The mesh must always be in "standard" format.
    ! First create a 9x9-mesh on [0,1]x[0,1], then convert to standard.
    call meshgen_rectangular2DQuadMesh (rtriangulation, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP, 8, 8)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Discretise with Q1.
    !
    ! Create a structure rspatialDiscr
    ! which describes the discretisation.
    ! We generate a 1x1 system with Q1.
    ! =================================

    ! Create a spatial discretisation with Q1
    call spdiscr_initDiscr_simple (rspatialDiscr,EL_Q1_2D,rtriangulation)

    ! Create a block discretisation with 1 block Q1.
    call spdiscr_initBlockDiscr (rblockDiscr,rtriangulation)
    call spdiscr_appendBlockComponent (rblockDiscr,rspatialDiscr)
    call spdiscr_commitBlockDiscr (rblockDiscr)

    ! =================================
    ! Create a scalar vector.
    ! =================================

    ! Create a vector.
    call lsysbl_createVector (rblockDiscr,rx)

    ! =================================
    ! Fill the vector with data.
    ! =================================

    ! Get a pointer to the data.
    call lsyssc_getbase_double (rx%RvectorBlock(1),p_Ddata)

    ! Get a pointer to the point coordinates.
    call storage_getbase_double2d (rtriangulation%h_DvertexCoords,p_DvertexCoords)

    ! Set the entries of the vector according to the function
    !    u(x,y) = 1/exp(x)
    do ivt=1,rx%NEQ
      dx = p_DvertexCoords(1,ivt)
      p_Ddata(ivt) = 1.0_DP / exp(dx)
    end do

    ! =================================
    ! Define cubature formula
    ! =================================

    ! Use a Gauss 3x3 formula for the discretisation.
    call spdiscr_createDefCubStructure (rspatialDiscr,rcubatureInfo,CUB_GEN_AUTO_G3)

    ! =================================
    ! Calculate the L2-norm of u
    ! =================================

    ! Pass u via rcoeffVectors to bma_buildIntegral
    call fev2_addVectorToEvalList (rcoeffVectors,rx%RvectorBlock(1),0)

    ! Calculate ||u||_L2^2
    call bma_buildIntegral (dintvalue,BMA_CALC_STANDARD,&
        bma_fcalc_L2norm,revalVectors=rcoeffVectors,rcubatureInfo=rcubatureInfo)

    call fev2_releaseVectorList(rcoeffVectors)

    ! Take the square root to get ||u||
    dintvalue = sqrt(dintvalue)

    call output_line ("L2-norm = "//trim(sys_sdL(dintvalue,10)))

    ! =================================
    ! Calculate the H1-(semi)norm of u
    ! =================================

    ! Pass u and Du via rcoeffVectors to bma_buildIntegral
    call fev2_addVectorToEvalList (rcoeffVectors,rx%RvectorBlock(1),1)

    ! Calculate |u|_H1^2 = ||Du||_L2^2
    call bma_buildIntegral (dintvalue,BMA_CALC_STANDARD,&
        bma_fcalc_H1norm,revalVectors=rcoeffVectors,rcubatureInfo=rcubatureInfo)

    call fev2_releaseVectorList(rcoeffVectors)

    ! Take the square root to get |u|_H1
    dintvalue = sqrt(dintvalue)

    call output_line ("H1-norm = "//trim(sys_sdL(dintvalue,10)))

    ! =================================
    ! Cleanup
    ! =================================

    ! Release the vector
    call lsysbl_releaseVector (rx)

    ! Cubature done.
    call spdiscr_releaseCubStructure (rcubatureInfo)

    ! Release the discretisation
    call spdiscr_releaseBlockDiscr (rblockDiscr)
    call spdiscr_releaseDiscr (rspatialDiscr)

    ! Release the triangulation
    call tria_done (rtriangulation)

  end subroutine

end module


*       Example 5.1
*	   write a fortran program to solve for Pi(r)numerically
*	   and compare with the analytical solution ?
*	   1 * d  { r^2 d Phi(r)}
*	  ---  -- {-------------} = -4*pi*rho
*	   r   dr {             }

*	   Phi(r)= r^-1*Phi(r)
*	   d^2 { Phi(r)}
*	   -------------  = -4*pi*rho
*        dr^2

        dimension PHI(0:200)
        exact(R)=1.0-(R+2)*Exp(-R)/2
        source(R)=-R*exp(-R)/2
        H=0.1
        Nstep=20./H
        const=H**2/12
        Sm=0.
        Sz=source(H)
        PHI(0)=0
        PHI(1)=exact(H)
        do 10 IR=1,Nstep-1
        R=(IR+1)*H
        Sp=source(R)
        PHI(IR+1)=2*Phi(IR)-PHI(IR-1)+ Const*(Sp+10.0*Sz+Sm)
        Sm=Sz
        Sz=Sp
        Diff=Exact(R)-PHi(IR)
        Print*,R,Exact(R),Phi(IR),Diff
10      continue
        stop
        end


! Like array_constructor_6.f90, but check constructors in which the length
! of each subarray can only be determined at run time.
! { dg-do run }
program main
  implicit none
  call build (9)
contains
  function gen (order)
    real, dimension (:, :), pointer :: gen
    integer :: order, i, j

    allocate (gen (order, order + 1))
    forall (i = 1 : order, j = 1 : order + 1) gen (i, j) = i * i + j
  end function gen

  ! Deliberately leaky!
  subroutine build (order)
    integer :: order, i

    call test (order, 0, (/ (gen (i), i = 1, order) /))
    call test (3, 2, (/ ((/ 1.5, 1.5, gen (i) /), i = 1, 3) /))
  end subroutine build

  subroutine test (order, prefix, values)
    real, dimension (:) :: values
    integer :: order, prefix, last, i, j, k

    last = 0
    do i = 1, order
      do j = 1, prefix
        last = last + 1
        if (values (last) .ne. 1.5) STOP 1
      end do
      do j = 1, i + 1
        do k = 1, i
          last = last + 1
          if (values (last) .ne. j + k * k) STOP 2
        end do
      end do
    end do
    if (size (values, dim = 1) .ne. last) STOP 3
  end subroutine test
end program main


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      PROGRAM EXMPL1
C     Example 1: Bohr-Sommerfeld quantization for bound states of the
C               Lennard-Jones Potential
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       !search for bound states
      GOTO 5
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE ARCHON
C finds the bound states of the Lennard-Jones potential
C from the Bohr-Sommerfeld quantization rule
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.E1'
C Local variables:
      REAL S                        !current value of action
      REAL E1                       !current value of energy
      REAL X1,X2                    !current turning points
      REAL F1                       !f=action/2 - pi/2 -ilevel*pi
      INTEGER ILEVEL                !current level
      REAL ENERGY(0:MAXLVL)         !energy of bound state
      REAL XIN(0:MAXLVL)            !inner turning point
      REAL XOUT(0:MAXLVL)           !outer turning point
      INTEGER NLINES                !number of lines printed to terminal
      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     output summary of parameters
      IF (TTERM) CALL PRMOUT(OUNIT,NLINES)
      IF (TFILE) CALL PRMOUT(TUNIT,NLINES)
      IF (GFILE) CALL PRMOUT(GUNIT,NLINES)
C
C     search for bound states
      E1=-1.                      !begin at the well bottom
      F1=-PI/2                    !the action is zero there
C
C     find the NLEVEL bound states
      DO 100 ILEVEL=0,NLEVEL-1
C
         CALL SEARCH(ILEVEL,E1,F1,X1,X2) !search for eigenvalue
         ENERGY(ILEVEL)=E1        !store values for this state
         XIN(ILEVEL)=X1
         XOUT(ILEVEL)=X2
C
C        text output
         IF (TTERM) CALL TXTOUT(OUNIT,ILEVEL,E1,X1,X2,NLINES)
         IF (TFILE) CALL TXTOUT(TUNIT,ILEVEL,E1,X1,X2,NLINES)
C
         F1=F1-PI                 !guess to begin search for next level
C
100   CONTINUE
C
      IF (TTERM) CALL PAUSE('to continue...',1)
      IF (TTERM) CALL CLEAR
C
C     graphics output
      IF (GTERM) CALL GRFOUT(SCREEN,ENERGY,XIN,XOUT)
      IF (GFILE) CALL GRFOUT(FILE,ENERGY,XIN,XOUT)
      IF (GHRDCP) CALL GRFOUT(PAPER,ENERGY,XIN,XOUT)
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
       SUBROUTINE SEARCH(N,E1,F1,X1,X2)
C finds the N'th bound state
C E1 is passed in as initial guess for the bound state energy
C    and returned as the true bound state energy with turning points
C    X1 and X2
C F1 is the function which goes to zero at a bound state
C    F1 = action/2-(n+1/2)*pi
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'PARAM.E1'
C Input/Output variables:
      INTEGER N                !current level (input)
      REAL E1,E2               !trial energies (I/O)
      REAL F1,F2               !f=action/2-pi*(n+1/2) (I/O)
      REAL S                   !action (output)
      REAL X1,X2               !turning points (output)
C Local variables:
      REAL DE                  !increment in energy search
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     guess the next energy in order to begin search
      E2=E1+ABS(E1)/4.
      DE=2*ETOL
C
C     use secant search to find the bound state
50    IF (ABS(DE) .GT. ETOL) THEN
         CALL ACTION(E2,X1,X2,S)          !S at new energy
         F2=S-(N+.5)*PI                   !F at new energy
         IF (F1 .NE. F2) THEN             !calculate new DE
            DE=-F2*(E2-E1)/(F2-F1)
         ELSE
            DE=0.
         END IF
C
         E1=E2                             !roll values
         F1=F2
         E2=E1+DE                          !increment energy
         IF (E2 .GE. 0) E2=-ETOL           !keep energy negative
       GOTO 50
       END IF
C
       RETURN
       END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
       SUBROUTINE ACTION(E,X1,X2,S)
C calculates the (action integral)/2 (S) and the classical turning
C points (X1,X2) for a given energy (E)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'PARAM.E1'
C Input/Output variables:
      REAL E                   !energy (input)
      REAL S                   !action (output)
      REAL X1,X2               !turning points (output)
C Local variables:
      REAL DX                  !increment in turning point search
      REAL H                   !quadrature step size
      REAL SUM                 !sum for integral
      INTEGER IFAC             !coefficient for Simpson's rule
      INTEGER IX               !index on X
      REAL X                   !current X value in sum
      REAL POT                 !potential as a function of X (function)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     find inner turning point; begin search at the well bottom
      X1=POTMIN
      DX=.1
50    IF (DX .GT. XTOL) THEN
         X1=X1-DX              !use simple search, going inward
         IF (POT(X1) .GE. E) THEN
            X1=X1+DX
            DX=DX/2
         END IF
      GOTO 50
      END IF
C
C     find the outer turning point; begin search at the well bottom
      X2=POTMIN
      DX=.1
120   IF (DX .GT. XTOL) THEN
         X2=X2+DX              !use simple search going outward
         IF (POT(X2) .GE. E) THEN
            X2=X2-DX
            DX=DX/2
         END IF
      GOTO 120
      END IF
C
C     Simpson's rule from X1+H to X2-H
      IF (MOD(NPTS,2) .EQ. 1) NPTS=NPTS+1    !NPTS must be even
      H=(X2-X1)/NPTS                         !step size
      SUM=SQRT(E-POT(X1+H))
      IFAC=2
      DO 200 IX=2,NPTS-2
          X=X1+IX*H
          IF (IFAC .EQ. 2) THEN              !alternate factors
              IFAC=4
          ELSE
              IFAC=2
          END IF
          SUM=SUM+IFAC*SQRT(E-POT(X))
200   CONTINUE
      SUM=SUM+SQRT(E-POT(X2-H))
      SUM=SUM*H/3
C
C     special handling for sqrt behavior of first and last intervals
      SUM=SUM+SQRT(E-POT(X1+H))*2*H/3
      SUM=SUM+SQRT(E-POT(X2-H))*2*H/3
      S=SUM*GAMMA
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
       REAL FUNCTION POT(X)
C evaluates the Lennard-Jones potential at X
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Passed variables:
       REAL X
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C If you change the potential, normalize to a minimum of -1
C and change the value of POTMIN in subroutine INIT to the
C new equilibrium position (i.e. the X value at which the force is zero)
C      Lennard-Jones potential in scaled variables
       POT=4*(X**(-12)-X**(-6))
       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.E1'
C Local parameters:
      CHARACTER*80 DESCRP          !program description
      DIMENSION DESCRP(20)
      INTEGER NHEAD,NTEXT,NGRAPH   !number of lines for each description
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     get environment parameters
      CALL SETUP
C
C     display header screen
      DESCRP(1)= 'EXAMPLE 1'
      DESCRP(2)= 'Bohr-Sommerfeld quantization for bound state'
      DESCRP(3)= 'energies of the 6-12 potential'
      NHEAD=3
C
C     text output description
      DESCRP(4)= 'energy and classical turning points for each state'
      NTEXT=1
C
C     graphics output description
      DESCRP(5)= 'phase space (wavenumber vs. position) portrait'
      DESCRP(6)= 'of classical trajectories'
      NGRAPH=2
C
      CALL HEADER(DESCRP,NHEAD,NTEXT,NGRAPH)
C
C     calculate constants
      PI=4*ATAN(1.0)
      POTMIN=2**(1.0/6.0)
C
C     setup menu arrays, beginning with constant part
      CALL MENU
C
      MTYPE(13)=FLOAT
      MPRMPT(13)= 'Enter gamma=sqrt(2*m*a**2*V/hbar**2) (dimensionless)'
      MTAG(13)= 'Gamma (dimensionless)'
      MLOLIM(13)=1.
      MHILIM(13)=500.
      MREALS(13)=50.
C
      MTYPE(14)=SKIP
      MREALS(14)=35.
C
      MTYPE(38)=FLOAT
      MPRMPT(38)= 'Enter tolerance for energy search (scaled units)'
      MTAG(38)= 'Energy search tolerance (scaled units)'
      MLOLIM(38)=.00001
      MHILIM(38)=.01
      MREALS(38)=.0005
C
      MTYPE(39)=FLOAT
      MPRMPT(39)=
     +'Enter tolerance for turning point search (scaled units)'
      MTAG(39)= 'Turning point search tolerance (scaled units)'
      MLOLIM(39)=.00001
      MHILIM(39)=.01
      MREALS(39)=.0005
C
      MTYPE(40)=NUM
      MPRMPT(40)= 'Enter number of points for action integral'
      MTAG(40)= 'Number of quadrature points for action integral'
      MLOLIM(40)=20.
      MHILIM(40)=5000.
      MINTS(40)=100
C
      MTYPE(41)=SKIP
      MREALS(41)=60.
C
      MSTRNG(MINTS(75))= 'exmpl1.txt'
C
      MTYPE(76)=SKIP
      MREALS(76)=80.
C
      MSTRNG(MINTS(86))= 'exmpl1.grf'
C
      MTYPE(87)=NUM
      MPRMPT(87)= 'Enter number of points to be used in graphing'
      MTAG(87)= 'Number of graphing points'
      MLOLIM(87)= 10.
      MHILIM(87)= MAXGRF-2
      MINTS(87)= 80
C
      MTYPE(88)=SKIP
      MREALS(88)=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.E1'
      INCLUDE 'MAP.E1'
C Local variables:
      REAL S                  !current value of action
      REAL E1                 !current value of energy
      REAL X1,X2              !current turning points
C Function:
      LOGICAL LOGCVT          !converts 1 and 0 to true and false
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     physical and numerical parameters
      GAMMA=MREALS(IGAMMA)
      ETOL=MREALS(IETOL)
      XTOL=MREALS(IXTOL)
      NPTS=MINTS(INPTS)
C
C     text output parameters
      TTERM=LOGCVT(MINTS(ITTERM))
      TFILE=LOGCVT(MINTS(ITFILE))
      TNAME=MSTRNG(MINTS(ITNAME))
C
C     graphics output parameters
      GTERM=LOGCVT(MINTS(IGTERM))
      GHRDCP=LOGCVT(MINTS(IGHRD))
      GFILE=LOGCVT(MINTS(IGFILE))
      GNAME=MSTRNG(MINTS(IGNAME))
      NGRF=MINTS(INGRF)
C
C     open files
      IF (TFILE) CALL FLOPEN(TNAME,TUNIT)
      IF (GFILE) CALL FLOPEN(GNAME,GUNIT)
C     files may have been renamed
      MSTRNG(MINTS(ITNAME))=TNAME
      MSTRNG(MINTS(IGNAME))=GNAME
C
C     calculate total number of levels
      E1=-ETOL
      CALL ACTION(E1,X1,X2,S)
      NLEVEL=INT(S/PI-.5)+1
C     check value of GAMMA
      CALL PCHECK
C
      CALL CLEAR
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
       SUBROUTINE PCHECK
C ensure that the number of states is not greater than the size of
C the data arrays; if so prompt for smaller GAMMA
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global parameters:
      INCLUDE 'PARAM.E1'
      INCLUDE 'MENU.ALL'
      INCLUDE 'IO.ALL'
      INCLUDE 'MAP.E1'
C Local parameters:
      REAL S                   !action
      REAL E                   !small negative energy
      REAL X1,X2               !classical turning points
C Function:
      REAL GETFLT              !returns a floating point variable
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10    IF ((NLEVEL-1) .GT. MAXLVL) THEN
          WRITE (OUNIT,15) NLEVEL,MAXLVL
          MHILIM(IGAMMA)=GAMMA
          MREALS(IGAMMA) =  GETFLT(MREALS(IGAMMA)/2,MLOLIM(IGAMMA),
     +                  MHILIM(IGAMMA), 'Enter a smaller gamma')
          GAMMA=MREALS(IGAMMA)
C
          E=-ETOL
          CALL ACTION(E,X1,X2,S)
          NLEVEL=INT(S/PI+.5)+1
      GOTO 10
      END IF
C
15    FORMAT (' Total number of levels (=',i5,
     +        ') is larger than maximum allowable (=',i3,')')
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
       SUBROUTINE PRMOUT(MUNIT,NLINES)
C outputs parameter summary to the specified unit
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
       INCLUDE 'IO.ALL'
       INCLUDE 'PARAM.E1'
C Input/Output 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,6) ETOL,XTOL
       WRITE (MUNIT,8) NPTS
       WRITE (MUNIT,10) GAMMA,NLEVEL
       WRITE (MUNIT,12)
       WRITE (MUNIT,2)
C
       IF (MUNIT .NE. GUNIT) THEN
         WRITE (MUNIT,20)
         WRITE (MUNIT,25)
       END IF
C
       NLINES=7
C
2      FORMAT (' ')
4      FORMAT (' Output from example 1: Bohr Sommerfeld Quantization')
6      FORMAT (' Energy tolerance =', E12.5,
     +         '   position tolerance =', E12.5)
8      FORMAT (' number of quadrature points =', I4)
10     FORMAT (' For gamma =', F8.2,' there are ', I4, ' levels:')
12     FORMAT (' (all quantities are expressed in scaled units)')
20     FORMAT (8X, 'Level', 8X, 'Energy', 12X, 'Xmin', 12X, 'Xmax')
25     FORMAT (8X, '-----', 8X, '------', 12X, '----', 12X ,'----')
C
       RETURN
       END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE TXTOUT(MUNIT,ILEVEL,E,X1,X2,NLINES)
C writes results for one state to the requested unit
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'IO.ALL'
C Input variables:
      INTEGER MUNIT                 !output unit specifier
      INTEGER ILEVEL                !current level
      REAL E                        !eigen energy
      REAL X1,X2                    !classical turning points
      INTEGER NLINES                !number of lines printed so far
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     if screen is full, clear screen and retype headings
      IF ((MOD(NLINES,TRMLIN-6) .EQ. 0)
     +                          .AND. (MUNIT .EQ. OUNIT)) THEN
         CALL PAUSE('to continue...',1)
         CALL CLEAR
         WRITE (MUNIT,20)
         WRITE (MUNIT,25)
      END IF
C
      WRITE (MUNIT,30) ILEVEL,E,X1,X2
C
C     keep track of printed lines only for terminal output
      IF (MUNIT .EQ. OUNIT) NLINES=NLINES+1
C
20    FORMAT (8X, 'Level', 8X, 'Energy', 12X, 'Xmin', 12X, 'Xmax')
25    FORMAT (8X, '-----', 8X, '------', 12X, '----', 12X ,'----')
30    FORMAT(8X,I4,3(8X,F8.5))
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
       SUBROUTINE GRFOUT(DEVICE,ENERGY,XIN,XOUT)
C outputs phase space portraits of the bound states to the terminal
C and/or a file
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global parameters:
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.E1'
      INCLUDE 'GRFDAT.ALL'
C Input variables:
      INTEGER DEVICE               !which device is being used?
      REAL ENERGY(0:MAXLVL)        !energy of bound state
      REAL XIN(0:MAXLVL)           !inner turning point
      REAL XOUT(0:MAXLVL)          !outer turning point
C Local parameters:
      INTEGER ILEVEL               !level index
      REAL H                       !step size for x
      INTEGER IX                   !x index
      REAL E                       !current energy
      REAL K(MAXGRF)               !current wavenumber
      REAL X(MAXGRF)               !current position
      CHARACTER*9 CGAMMA,CN        !Gamma,nlevel as a character string
      REAL POT                     !potential (function)
      INTEGER LEN,NLEN             !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
          NPLOT=1                       !how many plots
          IPLOT=1
C
          YMAX=GAMMA*SQRT(1.+ENERGY(NLEVEL-1))   !limits on data points
          YMIN=-YMAX
          XMIN=XIN(NLEVEL-1)
          XMAX=XOUT(NLEVEL-1)
          Y0VAL=XMIN
          X0VAL=0.
C
          IF (MOD(NGRF,2) .EQ. 0) NGRF=NGRF+1
          NPOINT=NGRF                   !keep number of points odd
C
          ILINE=1                       !line and symbol styles
          ISYM=1
          IFREQ=0
          NXTICK=5
          NYTICK=5
C
          CALL CONVRT(GAMMA,CGAMMA,LEN) !titles and labels
          CALL ICNVRT(NLEVEL,CN,NLEN)
          INFO=' NLEVEL = '//CN(1:NLEN)
          TITLE='Semiclassically Quantized Trajectories, Gamma='//CGAMMA
          LABEL(1)='scaled position'
          LABEL(2)='scaled wave number'
C
          CALL GTDEV(DEVICE)                   !device nomination
          IF (DEVICE .EQ. SCREEN) CALL GMODE   !change to graphics mode
          CALL LNLNAX                          !draw axes
      END IF
C
C     calculate classical phase space trajectory for each bound state
C     by finding the scaled wavenumber as a function of X and Energy
      DO 50 ILEVEL=0,NLEVEL-1
         E=ENERGY(ILEVEL)
         H=(XOUT(ILEVEL)-XIN(ILEVEL))/((NGRF-1)/2)  !step size
         X(1)=XIN(ILEVEL)
         K(1)=0.
C
         DO 20 IX=1,(NGRF-1)/2
            X(IX+1)=XIN(ILEVEL)+(IX)*H
            K(IX+1)=(E-POT(X(IX+1)))                !scaled wave number
            IF (K(IX) .LE. 0) THEN
               K(IX)=0.
            ELSE
               K(IX)=GAMMA*SQRT(K(IX))
            END IF
20       CONTINUE
C
         DO 30 IX=(NGRF+1)/2,NGRF-1   !graph is symmetric about x-axis
            X(IX+1)=X(NGRF-IX)
            K(IX+1)=-K(NGRF-IX)
30       CONTINUE
C
C        output results
         IF (DEVICE .EQ. FILE) THEN
             WRITE (GUNIT,75) E
             WRITE (GUNIT,70) (X(IX),K(IX),IX=1,NGRF)
         ELSE
             CALL XYPLOT(X,K)
         END IF
50    CONTINUE
C
C     end graphing session
      IF (DEVICE .NE. FILE) CALL GPAGE(DEVICE)   !close graphing package
      IF (DEVICE .EQ. SCREEN) CALL TMODE         !switch to text mode
C
70    FORMAT (2(5X,E11.3))
75    FORMAT (/,' Position vs. wave number for Energy =',1PE11.3)
100   FORMAT (/,' Patience, please; output going to a file.')
C
      RETURN
      END


      subroutine anrs01(r,ir,m,b,x,ind,io)
C     SUBROUTINE ANRS01(R,IR,M,B,X,IND,IO)
C
C***********************************************************************
C                                                                      *
C                                                                      *
C     Copyright:        Eduardo Casas Renteria                         *
C                       Cecilia Pola Mendez                            *
C                                                                      *
C       Departamento de Matematicas,Estadistica y Computacion          *
C       -----------------------------------------------------          *
C                     UNIVERSIDAD DE CANTABRIA                         *
C                     ------------------------                         *
C                          FEBRERO 1987                                *
C                                                                      *
C***********************************************************************
C
C     OBJETIVO:
C        Esta subrutina resuelve un sistema de ecuaciones lineales en el
C        que la matriz de coeficientes es triangular.
C
C     LISTA DE LLAMADA:
C     DE ENTRADA:
C
C        R      Matriz de dimension (IR,M),triangular superior.Contiene
C               en sus M primeras filas a la matriz de coeficientes del
C               sistema.La parte subdiagonal de R no es utilizada.
C
C        IR     Primera dimension de la matriz R. IR >= N.
C
C        M      Numero de filas y columnas de la matriz de coeficientes.
C
C        B      Vector M-dimensional.Guarda los terminos independientes
C               del sistema.
C
C        IND    Indica el tipo de sistema a resolver,con los valores:
C                  1  : Se resuelve R'x=b
C                  2  : Se resuelve Rx=b
C
C        IO     Numero de canal de salida de resultados.
C
C     DE SALIDA:
C
C        X      Vector m-dimensional en el que se recoge  la solucion
C               del sistema.
C
C        Esta subrutina trabaja en doble precision via una sentencia
C     "implicit":
C                Implicit double precision (a-h,o-z)
C
C     SUBPROGRAMAS AUXILIARES: ddot,d1mach
C     FUNCIONES FORTRAN INTRINSECAS: abs,mod
C
C
      implicit double precision(a-h,o-z)
      dimension r(ir,*),b(*),x(*)
C
C     Se comprueba si los valores de las variables son correctos
C
      if(m.lt.1 .or. ir.lt.1 .or. m.gt.ir .or. ind.lt.1 .or. ind.gt.2)
     &   then
         write(io,1000) 'INCORRECT LIST OF CALLING IN ANRS01.'
         stop
      end if
C
C     Se calcula un parametro para detectar la posible singularidad de
C     la matriz de coeficientes
C
css   epsmch=d1mach(4)**0.9
CX      epsmch=dlamch('p')**0.9
C
C     Se comienza la resolucion del sistema segun sea el indicador
C
      if(ind.eq.1) then
         j=1
      else
         j=m
      end if
CX      if(abs(r(j,j)).lt.epsmch) then
CX         write(io,1000) 'SINGULAR MATRIX IN ANRS01.'
CX         stop
CX      end if
      x(j)=b(j)/r(j,j)
      if(m.eq.1) return
      do 10 i=2,m
         i1=i-1
         if(ind.eq.1) then
            j=i
            j1=1
            j2=i
            j3=1
            k=1
         else
            j=m-i1
            j1=j
            j2=j+1
            j3=j2
            k=ir
         end if
CX         if(abs(r(j,j)).lt.epsmch) then
CX            write(io,1000) 'SINGULAR MATRIX IN ANRS01.'
CX            stop
CX         end if
         x(j)=(b(j)-ddot(i1,r(j1,j2),k,x(j3),1))/r(j,j)
10    continue
1000  format(10x,A)
      end


program reduction

   implicit none
   integer, parameter :: r15 = selected_real_kind(15)
   integer, parameter :: n = 40
   integer :: i, j

   real(kind=r15) :: euler = 1.0
   real(kind=r15) :: facto
   real(kind=r15), parameter :: e_ref = 2.71828182845904523536028747135266249775724709369995_r15

   !$OMP PARALLEL DO default(none) shared(euler) private(facto) reduction(+:euler)
   do i = 1, n

      facto = real(1)

      ! Not need to run this internal loop in the serial case
      ! Can you remove it and still use OpenMP?
      do j = 1, i
         facto = facto*j
      end do
      euler = euler + real(1)/facto
      print *, "I= ", i, "Euler Number: ", euler, "Error: ", abs(euler - e_ref)

   end do
   !$OMP END PARALLEL DO

   print *, "Final Euler Number: ", euler

end program


      program rebanamiento_formaciones
        implicit none
        integer :: i

        integer :: vector1(10)
        !1D formación de 10 elementos

        integer :: matriz2(10,10)
        !D2 formación de 100 elementos

        vector1=[1,2,3,4,5,6,7,8,9,10]
        !Constructor de formaciones
        print *,'vector1:'// achar(10) , vector1

        vector1=[(i,i=1,10)]
        !Constructor de formaciones con bucle implícito
        print *,'vector1:'
        print *, vector1

        vector1(:)=0
        !Por defecto todos los elementos igual a cero
        print *,'vector1:'// achar(10) , vector1

        vector1(1:5)=1
        !Establecer los 5 primeros elemento igual a uno
        print *,'vector1:'// achar(10) , vector1

        vector1(6:)=1
        !Establecer del sexto al ultimo elemento igual a 1
        print *,'vector1:'// achar(10) , vector1

        print *,'Indices pares de vector1:'// achar(10),vector1(1:10:2)
        !Imprimir todos los elemento con indice par

        print *,'Columna 1 de matriz2:'// achar(10),matriz2(:,1)
        !Imprimir la primera columna de la formación 2D

        print *,'vector1 en  orden invertido:'// achar(10),vector1(10:1:-1)
        !Imprimir la formación de diez elementos en orden decreciente por indice
      end program rebanamiento_formaciones


*----------------------------------------------------------------------*
      subroutine check_inv(ndim,mat,inv)
*----------------------------------------------------------------------*
*     Check if inv is the inverse matrix of mat, giving a report
*
*     ndim - dimension of the matrix
*
*     yuri, set 2015
*----------------------------------------------------------------------*
      implicit none

      include 'stdunit.h'

      integer, intent(in) ::
     &     ndim
      real(8), intent(in) ::
     &     mat(ndim,ndim), inv(ndim,ndim)

      integer ::
     &     i,j,k
      real(8) ::
     &     K_delta(ndim,ndim)

      do i=1,ndim
       do j=1,ndim
        K_delta(i,j) = 0d0
        do k=1,ndim
         K_delta(i,j) = K_delta(i,j) + mat(i,k)*inv(k,j)
        end do
       end do
      end do

      write(lulog,*) "====================="
      write(lulog,*) "   check_inv"
      write(lulog,*) "Initial matrix, A:"
      do i=1,ndim
       write(lulog,*) mat(i,:)
      end do
      write(lulog,*) "---"
      write(lulog,*) "Proposed inverse matrix, A^-1:"
      do i=1,ndim
       write(lulog,*) inv(i,:)
      end do
      write(lulog,*) "---"
      write(lulog,*) "Their product:"
      do i=1,ndim
       write(lulog,*) K_delta(i,:)
      end do
      write(lulog,*) "====================="

      end


      FUNCTION factrl(n)
      INTEGER n
      REAL factrl
CU    USES gammln
      INTEGER j,ntop
      REAL a(33),gammln
      SAVE ntop,a
      DATA ntop,a(1)/0,1./
      if (n.lt.0) then
        pause 'negative factorial in factrl'
      else if (n.le.ntop) then
        factrl=a(n+1)
      else if (n.le.32) then
        do 11 j=ntop+1,n
          a(j+1)=j*a(j)
11      continue
        ntop=n
        factrl=a(n+1)
      else
        factrl=exp(gammln(n+1.))
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/factrl.for


!> The global constants are stored here and passed between the subroutines
!! by including the module.
  module globalconsts
  implicit none

  integer, parameter                      :: dp = selected_real_kind(15,307)
! some complex numbers
  complex(dp),parameter                   :: c0=(0.D0,0.D0),cr=(1.D0,0.D0),ci=(0.D0,1.D0)
  real(dp),parameter                      :: pi=4.D0*DATAN(1.D0)

  end module globalconsts

!> The global variables are stored here and passed between the subroutines
!! by including the module. You can also put these in a separate file.
!! @param matdim specifies the dimensionality of the square matrices and vectors.
!! @param matval specifies some of the values inside the matrices/vectors and should
!!        be a real number.
!! @param specifies whether matrix diagonalization should be carried out

  module globalvars
  use globalconsts
  implicit none

  integer                                 :: matdim
  real(dp)                                :: matval
  logical                                 :: do_diag
  complex(dp),dimension(:,:),allocatable  :: complex_matrix
  real(dp),dimension(:,:),allocatable     :: real_matrix
  complex(dp),dimension(:),allocatable    :: complex_vector
  real(dp),dimension(:),allocatable       :: real_vector

  end module globalvars
!> @file


      program main

c*********************************************************************72
c
cc MAIN is the main program for CG_PRB.
c
c  Discussion:
c
c    CG_PRB tests the CG library.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    By Sourangshu Ghosh
c
c  Author:
c
c    Sourangshu Ghosh
c
      implicit none

      call timestamp ( )
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CG_PRB'
      write ( *, '(a)' ) '  FORTRAN77 version'
      write ( *, '(a)' ) '  Test the CG library.'

      call test01 ( )
      call test02 ( )
      call test023 ( )
      call test025 ( )
      call test03 ( )
      call test04 ( )
      call test05 ( )
c
c  Terminate.
c
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'CG_PRB'
      write ( *, '(a)' ) '  Normal end of execution.'
      write ( *, '(a)' ) ' '
      call timestamp ( )

      stop
      end
      subroutine test01 ( )

c*********************************************************************72
c
cc TEST01 tests R8GE_CG for a full storage matrix.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    By Sourangshu Ghosh
c
c  Author:
c
c    Sourangshu Ghosh
c
      implicit none

      integer n
      parameter ( n = 10 )

      double precision a(n,n)
      double precision b(n)
      double precision e_norm
      integer i
      double precision r(n)
      double precision r_norm
      double precision r8vec_diff_norm
      double precision r8vec_norm
      integer seed
      double precision x1(n)
      double precision x2(n)

      write ( *, '(a)' ) ''
      write ( *, '(a)' ) 'TEST01'
      write ( *, '(a)' )
     &  '  Test R8GE_CG, applying CG to a full storage matrix.'
c
c  Choose a random positive definite symmetric matrix A.
c
      seed = 123456789
      call pds_random ( n, seed, a )
c
c  Choose a random solution.
c
      seed = 123456789
      call r8vec_uniform_01 ( n, seed, x1 )
c
c  Compute the corresponding right hand side.
c
      call r8ge_mv ( n, n, a, x1, b )
c
c  Call the CG routine.
c
      do i = 1, n
        x2(i) = 1.0D+00
      end do

      call r8ge_cg ( n, a, b, x2 )
c
c  Compute the residual.
c
      call r8ge_resid ( n, n, a, x2, b, r )
      r_norm = r8vec_norm ( n, r )
c
c  Compute the error.
c
      e_norm = r8vec_diff_norm ( n, x1, x2 )
c
c  Report.
c
      write ( *, '(a)' ) ' '
      write ( *, '(a,i4)' ) '  Number of variables N = ', n
      write ( *, '(a,g14.6)' ) '  Norm of residual ||Ax-b|| = ', r_norm
      write ( *, '(a,g14.6)' ) '  Norm of error ||x1-x2|| = ', e_norm

      return
      end
      subroutine test02 ( )

c*********************************************************************72
c
cc TEST02 tests R83_CG.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    By Sourangshu Ghosh
c
c  Author:
c
c    Sourangshu Ghosh
c
      implicit none

      integer n
      parameter ( n = 10 )

      double precision a(3,n)
      double precision b(n)
      double precision e_norm
      integer i
      double precision r(n)
      double precision r_norm
      double precision r8vec_diff_norm
      double precision r8vec_norm
      integer seed
      double precision x1(n)
      double precision x2(n)

      write ( *, '(a)' ) ''
      write ( *, '(a)' ) 'TEST02'
      write ( *, '(a)' ) '  Test R83_CG, applying CG to an R83 matrix.'
c
c  Let A be the -1 2 -1 matrix.
c
      call r83_dif2 ( n, n, a )
c
c  Choose a random solution.
c
      seed = 123456789
      call r8vec_uniform_01 ( n, seed, x1 )
c
c  Compute the corresponding right hand side.
c
      call r83_mv ( n, n, a, x1, b )
c
c  Call the CG routine.
c
      do i = 1, n
        x2(i) = 1.0D+00
      end do

      call r83_cg ( n, a, b, x2 )
c
c  Compute the residual.
c
      call r83_resid ( n, n, a, x2, b, r )
      r_norm = r8vec_norm ( n, r )
c
c  Compute the error.
c
      e_norm = r8vec_diff_norm ( n, x1, x2 )
c
c  Report.
c
      write ( *, '(a)' ) ' '
      write ( *, '(a,i4)' ) '  Number of variables N = ', n
      write ( *, '(a,g14.6)' ) '  Norm of residual ||Ax-b|| = ', r_norm
      write ( *, '(a,g14.6)' ) '  Norm of error ||x1-x2|| = ', e_norm

      return
      end
      subroutine test023 ( )

c*********************************************************************72
c
cc TEST023 tests R83S_CG.
c
c  Licensing:
c
c    This code is distributed under the MIT license.
c
c  Modified:
c
c    09 July 2014
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 10 )

      double precision a(3)
      double precision b(n)
      double precision e_norm
      integer i
      double precision r(n)
      double precision r_norm
      double precision r8vec_diff_norm
      double precision r8vec_norm
      integer seed
      double precision x1(n)
      double precision x2(n)

      write ( *, '(a)' ) ''
      write ( *, '(a)' ) 'TEST023'
      write ( *, '(a)' )
     &  '  Test R83S_CG, applying CG to an R83S matrix.'
c
c  Let A be the -1 2 -1 matrix.
c
      call r83s_dif2 ( n, n, a )
c
c  Choose a random solution.
c
      seed = 123456789
      call r8vec_uniform_01 ( n, seed, x1 )
c
c  Compute the corresponding right hand side.
c
      call r83s_mv ( n, n, a, x1, b )
c
c  Call the CG routine.
c
      do i = 1, n
        x2(i) = 1.0D+00
      end do

      call r83s_cg ( n, a, b, x2 )
c
c  Compute the residual.
c
      call r83s_resid ( n, n, a, x2, b, r )
      r_norm = r8vec_norm ( n, r )
c
c  Compute the error.
c
      e_norm = r8vec_diff_norm ( n, x1, x2 )
c
c  Report.
c
      write ( *, '(a)' ) ' '
      write ( *, '(a,i4)' ) '  Number of variables N = ', n
      write ( *, '(a,g14.6)' ) '  Norm of residual ||Ax-b|| = ', r_norm
      write ( *, '(a,g14.6)' ) '  Norm of error ||x1-x2|| = ', e_norm

      return
      end
      subroutine test025 ( )

c*********************************************************************72
c
cc TEST025 tests R83T_CG.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    18 June 2014
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 10 )

      double precision a(3,n)
      double precision b(n)
      double precision e_norm
      integer i
      double precision r(n)
      double precision r_norm
      double precision r8vec_diff_norm
      double precision r8vec_norm
      integer seed
      double precision x1(n)
      double precision x2(n)

      write ( *, '(a)' ) ''
      write ( *, '(a)' ) 'TEST025'
      write ( *, '(a)' )
     &  '  Test R83T_CG, applying CG to an R83T matrix.'
c
c  Let A be the -1 2 -1 matrix.
c
      call r83t_dif2 ( n, n, a )
c
c  Choose a random solution.
c
      seed = 123456789
      call r8vec_uniform_01 ( n, seed, x1 )
c
c  Compute the corresponding right hand side.
c
      call r83t_mv ( n, n, a, x1, b )
c
c  Call the CG routine.
c
      do i = 1, n
        x2(i) = 1.0D+00
      end do

      call r83t_cg ( n, a, b, x2 )
c
c  Compute the residual.
c
      call r83t_resid ( n, n, a, x2, b, r )
      r_norm = r8vec_norm ( n, r )
c
c  Compute the error.
c
      e_norm = r8vec_diff_norm ( n, x1, x2 )
c
c  Report.
c
      write ( *, '(a)' ) ' '
      write ( *, '(a,i4)' ) '  Number of variables N = ', n
      write ( *, '(a,g14.6)' ) '  Norm of residual ||Ax-b|| = ', r_norm
      write ( *, '(a,g14.6)' ) '  Norm of error ||x1-x2|| = ', e_norm

      return
      end
      subroutine test03 ( )

c*********************************************************************72
c
cc TEST03 tests R8PBU_CG.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 June 2014
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer mu
      parameter ( mu = 1 )
      integer n
      parameter ( n = 10 )

      double precision a(mu+1,n)
      double precision b(n)
      double precision e_norm
      integer i
      double precision r(n)
      double precision r_norm
      double precision r8vec_diff_norm
      double precision r8vec_norm
      integer seed
      double precision x1(n)
      double precision x2(n)

      write ( *, '(a)' ) ''
      write ( *, '(a)' ) 'TEST03'
      write ( *, '(a)' )
     &  '  Test R8PBU_CG, applying CG to an R8PBU matrix.'
c
c  Let A be the -1 2 -1 matrix.
c
      call r8pbu_dif2 ( n, n, mu, a )
c
c  Choose a random solution.
c
      seed = 123456789
      call r8vec_uniform_01 ( n, seed, x1 )
c
c  Compute the corresponding right hand side.
c
      call r8pbu_mv ( n, n, mu, a, x1, b )
c
c  Call the CG routine.
c
      do i = 1, n
        x2(i) = 1.0D+00
      end do

      call r8pbu_cg ( n, mu, a, b, x2 )
c
c  Compute the residual.
c
      call r8pbu_resid ( n, n, mu, a, x2, b, r )
      r_norm = r8vec_norm ( n, r )
c
c  Compute the error.
c
      e_norm = r8vec_diff_norm ( n, x1, x2 )
c
c  Report.
c
      write ( *, '(a)' ) ' '
      write ( *, '(a,i4)' ) '  Number of variables N = ', n
      write ( *, '(a,g14.6)' ) '  Norm of residual ||Ax-b|| = ', r_norm
      write ( *, '(a,g14.6)' ) '  Norm of error ||x1-x2|| = ', e_norm

      return
      end
      subroutine test04 ( )

c*********************************************************************72
c
cc TEST04 tests R8SD_CG.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 June 2014
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 10 )
      integer ndiag
      parameter ( ndiag = 2 )

      double precision a(n,ndiag)
      double precision b(n)
      double precision e_norm
      integer i
      integer offset(ndiag)
      double precision r(n)
      double precision r_norm
      double precision r8vec_diff_norm
      double precision r8vec_norm
      integer seed
      double precision x1(n)
      double precision x2(n)

      write ( *, '(a)' ) ''
      write ( *, '(a)' ) 'TEST04'
      write ( *, '(a)' )
     &  '  Test R8SD_CG, applying CG to an R8SD matrix.'

      offset(1) = 0
      offset(2) = 1
c
c  Set A to the [-1 2 -1] matrix.
c
      call r8sd_dif2 ( n, n, ndiag, offset, a )
c
c  Choose a random solution.
c
      seed = 123456789
      call r8vec_uniform_01 ( n, seed, x1 )
c
c  Compute the corresponding right hand side.
c
      call r8sd_mv ( n, n, ndiag, offset, a, x1, b )
c
c  Call the CG routine.
c
      do i = 1, n
        x2(i) = 1.0D+00
      end do

      call r8sd_cg ( n, ndiag, offset, a, b, x2 )
c
c  Compute the residual.
c
      call r8sd_resid ( n, n, ndiag, offset, a, x2, b, r )
      r_norm = r8vec_norm ( n, r )
c
c  Compute the error.
c
      e_norm = r8vec_diff_norm ( n, x1, x2 )
c
c  Report.
c
      write ( *, '(a)' ) ' '
      write ( *, '(a,i4)' ) '  Number of variables N = ', n
      write ( *, '(a,g14.6)' ) '  Norm of residual ||Ax-b|| = ', r_norm
      write ( *, '(a,g14.6)' ) '  Norm of error ||x1-x2|| = ', e_norm

      return
      end
      subroutine test05 ( )

c*********************************************************************72
c
cc TEST05 tests R8SP_CG.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 June 2014
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 10 )
      integer nz_num
      parameter ( nz_num = 3 * n - 2 )

      double precision a(nz_num)
      double precision b(n)
      integer col(nz_num)
      double precision e_norm
      integer i
      double precision r(n)
      integer row(nz_num)
      double precision r_norm
      double precision r8vec_diff_norm
      double precision r8vec_norm
      integer seed
      double precision x1(n)
      double precision x2(n)

      write ( *, '(a)' ) ''
      write ( *, '(a)' ) 'TEST05'
      write ( *, '(a)' )
     &  '  Test R8SP_CG, applying CG to an R8SP matrix.'
c
c  Set A to the [-1 2 -1] matrix.
c
      call r8sp_dif2 ( n, n, nz_num, row, col, a )
c
c  Choose a random solution.
c
      seed = 123456789
      call r8vec_uniform_01 ( n, seed, x1 )
c
c  Compute the corresponding right hand side.
c
      call r8sp_mv ( n, n, nz_num, row, col, a, x1, b )
c
c  Call the CG routine.
c
      do i = 1, n
        x2(i) = 1.0D+00
      end do

      call r8sp_cg ( n, nz_num, row, col, a, b, x2 )
c
c  Compute the residual.
c
      call r8sp_resid ( n, n, nz_num, row, col, a, x2, b, r )
      r_norm = r8vec_norm ( n, r )
c
c  Compute the error.
c
      e_norm = r8vec_diff_norm ( n, x1, x2 )
c
c  Report.
c
      write ( *, '(a)' ) ' '
      write ( *, '(a,i4)' ) '  Number of variables N = ', n
      write ( *, '(a,g14.6)' ) '  Norm of residual ||Ax-b|| = ', r_norm
      write ( *, '(a,g14.6)' ) '  Norm of error ||x1-x2|| = ', e_norm

      return
      end


        subroutine shp4T (QuadPt, nQpt,   shp,    shgl,   wght)
c
c----------------------------------------------------------------------
c
c  This subroutine generates shape functions for the 4-node
c   tetrahedra.
c
c input:
c  QuadPt (4,nQpt)              : quadrature points' local coord's
c                                   QuadPt(1,*) : r
c                                   QuadPt(2,*) : s
c                                   QuadPt(3,*) : t
c                                   QuadPt(4,*) : wght
c  nQpt                         : number of quadrature points
c
c output:
c  shp    (nen,nQpt)            : shape functions
c  shgl   (nsd,nen,nQpt)        : local-gradient of shape function
c  wght   (nQpt)                : quadrature weights
c
c
c shape-functions:
c  N1 = 1 - r - s - t
c  N2 = r
c  N3 = s
c  N4 = t
c
c Note: To be compatible with design of Tau and DC, the local
c       gradients are divided by 2.  This is equivalent to having
c       r=[-1,1], s=[-1,1] and t=[-1,1], without really changing
c       r, s and t points (i.e., Qpt is for r=[0,1], s=[0,1] and
c       t=[0,1] range)
c
c Zdenek Johan, Summer 1990.
c----------------------------------------------------------------------
c
        include "common.h"
c
        dimension QuadPt(4,*),                   shp(nen,*),
     &            shgl(nsd,nen,*),               wght(*)
c
c.... loop through quadrature points
c
        do m = 1, nQpt
c
c.... generate the local-shape-functions
c
          shp(1,m) = one - QuadPt(1,m) - QuadPt(2,m) - QuadPt(3,m)
          shp(2,m) = QuadPt(1,m)
          shp(3,m) = QuadPt(2,m)
          shp(4,m) = QuadPt(3,m)
c
c.... generate the grad-local-shape-functions
c
          shgl(1,1,m) = -pt5
          shgl(2,1,m) = -pt5
          shgl(3,1,m) = -pt5
          shgl(1,2,m) =  pt5
          shgl(2,2,m) =  zero
          shgl(3,2,m) =  zero
          shgl(1,3,m) =  zero
          shgl(2,3,m) =  pt5
          shgl(3,3,m) =  zero
          shgl(1,4,m) =  zero
          shgl(2,4,m) =  zero
          shgl(3,4,m) =  pt5
c
c.... copy the weight
c
          wght(m) = QuadPt(4,m)
c
c.... end of shape-function loop
c
        enddo
c
c.... return
c
        return
        end