! (C) Copyright 2019 UCAR and 2011-2018 John Thuburn, University of Exeter, UK
!
! This software is licensed under the terms of the Apache Licence Version 2.0
! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.

module femps_testgrid_mod

use femps_kinds_mod
use femps_grid_mod
use femps_const_mod
use femps_utils_mod

implicit none
private
public cstestgrid

! --------------------------------------------------------------------------------------------------

contains

! --------------------------------------------------------------------------------------------------

subroutine cstestgrid(grid)

implicit none
type(fempsgrid),   intent(inout) :: grid

integer :: igrid, i, j, ixv, iv, n, n2
real(kind=kind_real) :: dlambda, lambda1, lambda2, t1, t2, long, lat, &
                        x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4, x5, y5, z5, x6, y6, z6, &
                        lambdaf1, lambdaf2, tf1, tf2, xf1, yf1, zf1, xf2, yf2, zf2, &
                        xf3, yf3, zf3, xf4, yf4, zf4, xf5, yf5, zf5, xf6, yf6, zf6

! Generate the grid
! -----------------
do igrid = 1, grid%ngrids

  ! Size of panels on this grid
  n = grid%ncube(igrid)
  n2 = n*n
  dlambda = 0.5_kind_real*pi/n

  !
  ! Loop over vertices/faces of one panel
  do j = 1, n
    lambda2 = (j-1)*dlambda - piby4
    lambdaf2 = (j-0.5_kind_real)*dlambda - piby4
    t2 = tan(lambda2)
    tf2 = tan(lambdaf2)
    do i = 1, n
      lambda1 = (i-1)*dlambda - piby4
      lambdaf1 = (i-0.5_kind_real)*dlambda - piby4
      t1 = tan(lambda1)
      tf1 = tan(lambdaf1)

  !   Set up coordinates of vertices and faces
  !   Panel 1
  !   Index of vertex
      ixv = (j-1)*n + i
  !   Cartesian coordinates of vertex
      x1 = 1.0_kind_real/sqrt(1.0_kind_real + t1*t1 + t2*t2)
      y1 = x1*t1
      z1 = x1*t2
  !   Lat long coordinates of vertex
      call xyz2ll(x1,y1,z1,long,lat)
      grid%vlong(ixv,igrid) = long
      grid%vlat(ixv,igrid) = lat
  !   Cartesian coordinates of face
      xf1 = 1.0_kind_real/sqrt(1.0_kind_real + tf1*tf1 + tf2*tf2)
      yf1 = xf1*tf1
      zf1 = xf1*tf2
  !   Lat long coordinates of face
      call xyz2ll(xf1,yf1,zf1,long,lat)
      grid%flong(ixv,igrid) = long
      grid%flat(ixv,igrid) = lat

  !   Panel 2
  !   Index of vertex
      ixv = ixv + n2
  !   Cartesian coordinates of vertex
      x2 = -y1
      y2 = x1
      z2 = z1
  !   Lat long coordinates of vertex
      call xyz2ll(x2,y2,z2,long,lat)
      grid%vlong(ixv,igrid) = long
      grid%vlat(ixv,igrid) = lat
  !   Cartesian coordinates of face
      xf2 = -yf1
      yf2 = xf1
      zf2 = zf1
  !   Lat long coordinates of face
      call xyz2ll(xf2,yf2,zf2,long,lat)
      grid%flong(ixv,igrid) = long
      grid%flat(ixv,igrid) = lat

  !   Panel 3
  !   Index of vertex
      ixv = ixv + n2
  !   Cartesian coordinates of vertex
      x3 = x2
      y3 = -z2
      z3 = y2
  !   Lat long coordinates of vertex
      call xyz2ll(x3,y3,z3,long,lat)
      grid%vlong(ixv,igrid) = long
      grid%vlat(ixv,igrid) = lat
  !   Cartesian coordinates of face
      xf3 = xf2
      yf3 = -zf2
      zf3 = yf2
  !   Lat long coordinates of face
      call xyz2ll(xf3,yf3,zf3,long,lat)
      grid%flong(ixv,igrid) = long
      grid%flat(ixv,igrid) = lat

  !   Panel 4
  !   Index of vertex
      ixv = ixv + n2
  !   Cartesian coordinates of vertex
      x4 = -z3
      y4 = y3
      z4 = x3
  !   Lat long coordinates of vertex
      call xyz2ll(x4,y4,z4,long,lat)
      grid%vlong(ixv,igrid) = long
      grid%vlat(ixv,igrid) = lat
  !   Cartesian coordinates of face
      xf4 = -zf3
      yf4 = yf3
      zf4 = xf3
  !   Lat long coordinates of face
      call xyz2ll(xf4,yf4,zf4,long,lat)
      grid%flong(ixv,igrid) = long
      grid%flat(ixv,igrid) = lat

  !   Panel 5
  !   Index of vertex
      ixv = ixv + n2
  !   Cartesian coordinates of vertex
      x5 = -y4
      y5 = x4
      z5 = z4
  !   Lat long coordinates of vertex
      call xyz2ll(x5,y5,z5,long,lat)
      grid%vlong(ixv,igrid) = long
      grid%vlat(ixv,igrid) = lat
  !   Cartesian coordinates of face
      xf5 = -yf4
      yf5 = xf4
      zf5 = zf4
  !   Lat long coordinates of face
      call xyz2ll(xf5,yf5,zf5,long,lat)
      grid%flong(ixv,igrid) = long
      grid%flat(ixv,igrid) = lat

  !   Panel 6
  !   Index of vertex
      ixv = ixv + n2
  !   Cartesian coordinates of vertex
      x6 = x5
      y6 = -z5
      z6 = y5
  !   Lat long coordinates of vertex
      call xyz2ll(x6,y6,z6,long,lat)
      grid%vlong(ixv,igrid) = long
      grid%vlat(ixv,igrid) = lat
  !   Cartesian coordinates of face
      xf6 = xf5
      yf6 = -zf5
      zf6 = yf5
  !   Lat long coordinates of face
      call xyz2ll(xf6,yf6,zf6,long,lat)
      grid%flong(ixv,igrid) = long
      grid%flat(ixv,igrid) = lat

    enddo
  enddo

  ! Vertex 6*n2 + 1 is at top left of panels 1, 3, and 5
  iv = 6*n2 + 1
  lambda2 = piby4
  t2 = tan(lambda2)
  lambda1 = - piby4
  t1 = tan(lambda1)
  ! Cartesian coordinates of vertex
  x1 = 1.0_kind_real/sqrt(1.0_kind_real + t1*t1 + t2*t2)
  y1 = x1*t1
  z1 = x1*t2
  ! Lat long coordinates of vertex
  call xyz2ll(x1,y1,z1,long,lat)
  grid%vlong(iv,igrid) = long
  grid%vlat(iv,igrid) = lat

  ! Vertex 6*n2 + 2 is at bottom right of panels 2, 4, and 6
  iv = 6*n2 + 2
  x1 = -x1
  y1 = -y1
  z1 = -z1
  ! Lat long coordinates of vertex
  call xyz2ll(x1,y1,z1,long,lat)
  grid%vlong(iv,igrid) = long
  grid%vlat(iv,igrid) = lat

enddo ! End of main loop over grids

end subroutine cstestgrid

! --------------------------------------------------------------------------------------------------

end module femps_testgrid_mod


      subroutine cocosp(m,x,y,w,n,t,e,maxtr,maxbin,c,sq,sx,bind,wrk,
     * lwrk,iwrk,kwrk,ier)
c  given the set of data points (x(i),y(i)) and the set of positive
c  numbers w(i),i=1,2,...,m, subroutine cocosp determines the weighted
c  least-squares cubic spline s(x) with given knots t(j),j=1,2,...,n
c  which satisfies the following concavity/convexity conditions
c      s''(t(j+3))*e(j) <= 0, j=1,2,...n-6
c  the fit is given in the b-spline representation( b-spline coef-
c  ficients c(j),j=1,2,...n-4) and can be evaluated by means of
c  subroutine splev.
c
c  calling sequence:
c     call cocosp(m,x,y,w,n,t,e,maxtr,maxbin,c,sq,sx,bind,wrk,
c    * lwrk,iwrk,kwrk,ier)
c
c  parameters:
c    m   : integer. on entry m must specify the number of data points.
c          m > 3. unchanged on exit.
c    x   : real array of dimension at least (m). before entry, x(i)
c          must be set to the i-th value of the independent variable x,
c          for i=1,2,...,m. these values must be supplied in strictly
c          ascending order. unchanged on exit.
c    y   : real array of dimension at least (m). before entry, y(i)
c          must be set to the i-th value of the dependent variable y,
c          for i=1,2,...,m. unchanged on exit.
c    w   : real array of dimension at least (m). before entry, w(i)
c          must be set to the i-th value in the set of weights. the
c          w(i) must be strictly positive. unchanged on exit.
c    n   : integer. on entry n must contain the total number of knots
c          of the cubic spline. m+4>=n>=8. unchanged on exit.
c    t   : real array of dimension at least (n). before entry, this
c          array must contain the knots of the spline, i.e. the position
c          of the interior knots t(5),t(6),...,t(n-4) as well as the
c          position of the boundary knots t(1),t(2),t(3),t(4) and t(n-3)
c          t(n-2),t(n-1),t(n) needed for the b-spline representation.
c          unchanged on exit. see also the restrictions (ier=10).
c    e   : real array of dimension at least (n). before entry, e(j)
c          must be set to 1 if s(x) must be locally concave at t(j+3),
c          to (-1) if s(x) must be locally convex at t(j+3) and to 0
c          if no convexity constraint is imposed at t(j+3),j=1,2,..,n-6.
c          e(n-5),...,e(n) are not used. unchanged on exit.
c  maxtr : integer. on entry maxtr must contain an over-estimate of the
c          total number of records in the used tree structure, to indic-
c          ate the storage space available to the routine. maxtr >=1
c          in most practical situation maxtr=100 will be sufficient.
c          always large enough is
c                         n-5       n-6
c              maxtr =  (     ) + (     )  with l the greatest
c                          l        l+1
c          integer <= (n-6)/2 . unchanged on exit.
c  maxbin: integer. on entry maxbin must contain an over-estimate of the
c          number of knots where s(x) will have a zero second derivative
c          maxbin >=1. in most practical situation maxbin = 10 will be
c          sufficient. always large enough is maxbin=n-6.
c          unchanged on exit.
c    c   : real array of dimension at least (n).
c          on succesful exit, this array will contain the coefficients
c          c(1),c(2),..,c(n-4) in the b-spline representation of s(x)
c    sq  : real. on succesful exit, sq contains the weighted sum of
c          squared residuals of the spline approximation returned.
c    sx  : real array of dimension at least m. on succesful exit
c          this array will contain the spline values s(x(i)),i=1,...,m
c   bind : logical array of dimension at least (n). on succesful exit
c          this array will indicate the knots where s''(x)=0, i.e.
c                s''(t(j+3)) .eq. 0 if  bind(j) = .true.
c                s''(t(j+3)) .ne. 0 if  bind(j) = .false., j=1,2,...,n-6
c   wrk  : real array of dimension at least  m*4+n*7+maxbin*(maxbin+n+1)
c          used as working space.
c   lwrk : integer. on entry,lwrk must specify the actual dimension of
c          the array wrk as declared in the calling (sub)program.lwrk
c          must not be too small (see wrk). unchanged on exit.
c   iwrk : integer array of dimension at least (maxtr*4+2*(maxbin+1))
c          used as working space.
c   kwrk : integer. on entry,kwrk must specify the actual dimension of
c          the array iwrk as declared in the calling (sub)program. kwrk
c          must not be too small (see iwrk). unchanged on exit.
c   ier   : integer. error flag
c      ier=0 : succesful exit.
c      ier>0 : abnormal termination: no approximation is returned
c        ier=1  : the number of knots where s''(x)=0 exceeds maxbin.
c                 probably causes : maxbin too small.
c        ier=2  : the number of records in the tree structure exceeds
c                 maxtr.
c                 probably causes : maxtr too small.
c        ier=3  : the algoritm finds no solution to the posed quadratic
c                 programming problem.
c                 probably causes : rounding errors.
c        ier=10 : on entry, the input data are controlled on validity.
c                 the following restrictions must be satisfied
c                   m>3, maxtr>=1, maxbin>=1, 8<=n<=m+4,w(i) > 0,
c                   x(1)<x(2)<...<x(m), t(1)<=t(2)<=t(3)<=t(4)<=x(1),
c                   x(1)<t(5)<t(6)<...<t(n-4)<x(m)<=t(n-3)<=...<=t(n),
c                   kwrk>=maxtr*4+2*(maxbin+1),
c                   lwrk>=m*4+n*7+maxbin*(maxbin+n+1),
c                   the schoenberg-whitney conditions, i.e. there must
c                   be a subset of data points xx(j) such that
c                     t(j) < xx(j) < t(j+4), j=1,2,...,n-4
c                 if one of these restrictions is found to be violated
c                 control is immediately repassed to the calling program
c
c
c  other subroutines required:
c    fpcosp,fpbspl,fpadno,fpdeno,fpseno,fpfrno,fpchec
c
c  references:
c   dierckx p. : an algorithm for cubic spline fitting with convexity
c                constraints, computing 24 (1980) 349-371.
c   dierckx p. : an algorithm for least-squares cubic spline fitting
c                with convexity and concavity constraints, report tw39,
c                dept. computer science, k.u.leuven, 1978.
c   dierckx p. : curve and surface fitting with splines, monographs on
c                numerical analysis, oxford university press, 1993.
c
c  author:
c   p. dierckx
c   dept. computer science, k.u.leuven
c   celestijnenlaan 200a, b-3001 heverlee, belgium.
c   e-mail : Paul.Dierckx@cs.kuleuven.ac.be
c
c  creation date : march 1978
c  latest update : march 1987.
c
c  ..
c  ..scalar arguments..
      real*8 sq
      integer m,n,maxtr,maxbin,lwrk,kwrk,ier
c  ..array arguments..
      real*8 x(m),y(m),w(m),t(n),e(n),c(n),sx(m),wrk(lwrk)
      integer iwrk(kwrk)
      logical bind(n)
c  ..local scalars..
      integer i,ia,ib,ic,iq,iu,iz,izz,ji,jib,jjb,jl,jr,ju,kwest,
     * lwest,mb,nm,n6
      real*8 one
c  ..
c  set constant
      one = 0.1e+01
c  before starting computations a data check is made. if the input data
c  are invalid, control is immediately repassed to the calling program.
      ier = 10
      if(m.lt.4 .or. n.lt.8) go to 40
      if(maxtr.lt.1 .or. maxbin.lt.1) go to 40
      lwest = 7*n+m*4+maxbin*(1+n+maxbin)
      kwest = 4*maxtr+2*(maxbin+1)
      if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 40
      if(w(1).le.0.) go to 40
      do 10 i=2,m
         if(x(i-1).ge.x(i) .or. w(i).le.0.) go to 40
  10  continue
      call fpchec(x,m,t,n,3,ier)
      if (ier.eq.0) go to 20
      go to 40
c  set numbers e(i)
  20  n6 = n-6
      do 30 i=1,n6
        if(e(i).gt.0.) e(i) = one
        if(e(i).lt.0.) e(i) = -one
  30  continue
c  we partition the working space and determine the spline approximation
      nm = n+maxbin
      mb = maxbin+1
      ia = 1
      ib = ia+4*n
      ic = ib+nm*maxbin
      iz = ic+n
      izz = iz+n
      iu = izz+n
      iq = iu+maxbin
      ji = 1
      ju = ji+maxtr
      jl = ju+maxtr
      jr = jl+maxtr
      jjb = jr+maxtr
      jib = jjb+mb
      call fpcosp(m,x,y,w,n,t,e,maxtr,maxbin,c,sq,sx,bind,nm,mb,wrk(ia),
     *
     * wrk(ib),wrk(ic),wrk(iz),wrk(izz),wrk(iu),wrk(iq),iwrk(ji),
     * iwrk(ju),iwrk(jl),iwrk(jr),iwrk(jjb),iwrk(jib),ier)
  40  return
      end


        SUBROUTINE NORAD(EMIDTIM,X,Y,Z,R,VX,VY,VZ,
     1                   LNG,LAT,RHST,DHST,GMST,ISTAT)
c
c  Ephemeris of HST using NORAD TLES and "spacetrack" code (SGP4/8)
c
c  ------------------------------------------------------------------------
c  Part of "poa_calfos" (STECF/IPMG)
c  Part of "NORAD TLES" based ephemeris program (NASA)
c
c  History:
c  --------
c  Version   Date        Author          Description
c      1.0       Jul 00  M. Rosa         POA calibration code
c      1.2       Jun 01  A. Alexov       Added IDS's common block for file
c                                        header access
c      1.2.1     Oct 01  A. Alexov       Moved "IMPLICIT NONE" statement
c                                        to the beginning to fix Dec Alpha
c                                        compilation error
c  ------------------------------------------------------------------------
c
      IMPLICIT NONE

      INTEGER ISTAT
      INTEGER STDOUT
      PARAMETER (STDOUT = 1)
      INTEGER STDERR
      PARAMETER (STDERR = 2)
c      CHARACTER*80 CONTXT

        REAL*8 EMIDTIM,X,Y,Z,R,VX,VY,VZ,LNG,LAT,RHST,DHST,GMST
        REAL*8 PI,TPI
        PARAMETER (PI = 3.1415926535898D0)
C
C Common block containing input/output file descriptions
C
C       IDS - file id numbers
C       GCOUNT - group counts
C       NAXIS - naxis
C       NAXIS1 - first dimensions
C       NAXIS2 - second dimensions
C       FILL - Fill values
C
        INTEGER IDS(30),NAXIS(30),NAXIS1(30),NAXIS2(30),GCOUNT(30)
        REAL FILL(30)
        COMMON /IOCOM/IDS,GCOUNT,NAXIS,NAXIS1,NAXIS2,FILL
C
C LOCAL VARIABLES ------------------------------------------------------
        REAL*8 RA, DEC
c        REAL*8 RGREN,RAGREN
c        REAL*8 DELTAPOS
        REAL*8 STRAD,MIDNIT,FRACEN,STMIDN
        INTEGER*4 jepo,ISTAT
C-----------------------------------------------------------------------
      TPI = 2.0D0*PI
C... spacetrack
      CALL sgp4_driver (EMIDTIM,4,X,Y,Z,VX,VY,VZ,jepo,ISTAT)
      IF(ISTAT.NE.0)THEN
              GO TO 999
      ENDIF

      R = DSQRT(X*X+Y*Y+Z*Z)
C need sidereal time to compute longitude and latitude, mjd at midnite (days)
      MIDNIT = INT(EMIDTIM)
C fractional centuries since 2000
      FRACEN = (MIDNIT - 51544.5D0)/36525.0D0
C sidereal time at midnite in seconds
      STMIDN = MOD(24110.54841D0+8640184.812866D0*FRACEN
     1            +0.093104*FRACEN*FRACEN,86400.0D0)+86400.0D0
      GMST = STMIDN/3600.0D0
C sidereal time in radians
      STRAD = TPI/86400.0D0*MOD(STMIDN+((EMIDTIM-MIDNIT)
     1           *86400.0D0)*1.0027379093D0,86400.0D0)
c      GMST = STRAD*180.0D0/PI*24.0D0/360.0D0
      GMST = STMIDN/3600.0D0
C latitude, orgiginal version  OK
      DEC = DASIN(Z/R)
      LAT = 180.0D0/PI*DEC
C longitude (make sure the quadrant is correct!), else original version OK
      RA = DATAN2(Y,X)
      IF (RA .LT. 0.0D0) RA = RA + TPI
      LNG = 180.0D0/PI*(RA - STRAD)      ! this is correct
      IF (LNG .GT. 360.0D0) THEN
        LNG = LNG - 360.0D0
      ELSE IF (LNG .LT. 0.0D0) THEN
        LNG = LNG + 360.0D0
      ENDIF
      RHST = RA*180.0D0/PI
      DHST = LAT
C
 9999  CONTINUE
      ISTAT=0
      GOTO 1000

 999    ISTAT=1
 1000   RETURN
        END
c-- end of NORAD


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine gaspipe(node1,node2,nodem,nelem,lakon,kon,ipkon,
     &        nactdog,identity,ielprop,prop,iflag,v,xflow,f,
     &        nodef,idirf,df,cp,r,physcon,dvi,numf,set,shcon,
     &        nshcon,rhcon,nrhcon,ntmat_,mi,iaxial)
!
!     pipe with friction losses
!
!     author: Yannick Muller
!
      implicit none
!
      logical identity,crit
      character*8 lakon(*)
      character*81 set(*)
!
      integer nelem,nactdog(0:3,*),node1,node2,nodem,numf,
     &     ielprop(*),nodef(5),idirf(5),index,iflag,
     &     inv,ipkon(*),kon(*),icase,kgas,k_oil,nshcon(*),
     &     nrhcon(*),ntmat_,mi(*),iaxial
!
      real*8 prop(*),v(0:mi(2),*),xflow,f,df(5),kappa,R,a,d,l,
     &     p1,p2,T1,T2,Tt1,Tt2,pt1,pt2,cp,physcon(*),p2p1,km1,dvi,
     &     kp1,kdkm1,reynolds,pi,e,lambda,lld,kdkp1,T2dTt2,
     &     T1dTt1,X_t1dTt1,X_t2dTt2,X2_den,X1_den,
     &     X1,X2,B1,B2,C1,C2,t_moy,tdkp1,ln,m2r2d2a2,
     &     pt2zpt1,ks,form_fact,Tt1dT1,Tt2dT2,M1,M2,
     &     Pt2zPt1_c,qred_crit,l_neg,Qred,Ts1,qred_max1,phi,xflow_oil,
     &     shcon(0:3,ntmat_,*),rhcon(0:1,ntmat_,*)
!
      if (iflag.eq.0) then
         identity=.true.
!
         if(nactdog(2,node1).ne.0)then
            identity=.false.
         elseif(nactdog(2,node2).ne.0)then
            identity=.false.
         elseif(nactdog(1,nodem).ne.0)then
            identity=.false.
         endif
!

      elseif (iflag.eq.1)then
!
         crit=.false.
!
         index=ielprop(nelem)
         kappa=(cp/(cp-R))
         A=prop(index+1)
         d=prop(index+2)
         l=prop(index+3)
         if(l.lt.0d0) then
            l_neg=l
            l=abs(l)
         else
            l_neg=l
         endif
         ks=prop(index+4)
         if(lakon(nelem)(2:6).eq.'GAPIA') then
            icase=0
         elseif(lakon(nelem)(2:6).eq.'GAPII') then
            icase=1
         endif
         form_fact=prop(index+5)
         xflow_oil=prop(index+6)
         k_oil=int(prop(index+7))
!
         p1=v(2,node1)
         p2=v(2,node2)
!
         if(p1.ge.p2) then
            inv=1
            T1=v(0,node1)+physcon(1)
            T2=v(0,node2)+physcon(1)
         else
            inv=-1
            p1=v(2,node2)
            p2=v(2,node1)
            T1=v(0,node2)+physcon(1)
            T2=v(0,node1)+physcon(1)
         endif
!
         p2p1=p2/p1
         km1=kappa-1.d0
         kp1=kappa+1.d0
         kdkm1=kappa/km1
         tdkp1=2.d0/kp1
         C2=tdkp1**kdkm1
!
         if(p2p1.gt.C2) then
            xflow=inv*p1*a*dsqrt(2.d0*kdkm1*p2p1**(2.d0/kappa)
     &           *(1.d0-p2p1**(1.d0/kdkm1))/r)/dsqrt(T1)
         else
            xflow=inv*p1*a*dsqrt(kappa/r)*tdkp1**(kp1/(2.d0*km1))/
     &           dsqrt(T1)
         endif
!
!     calculation of the dynamic viscosity
!
         if(dabs(dvi).lt.1E-30) then
            kgas=0
            call dynamic_viscosity(kgas,T1,dvi)
         endif
!
         reynolds=dabs(xflow)*d/(dvi*a)
!
         if(reynolds.lt.100) then
            reynolds = 100
         endif
!
         call friction_coefficient(l_neg,d,ks,reynolds,form_fact,lambda)
!
         call pt2zpt1_crit(p2,p1,T1,T2,lambda,kappa,r,l,d,A,iflag,
     &        inv,Pt2zPt1_c,Qred_crit,crit,qred_max1,icase)
!
!        next location is "misused" to store the critical value
!        used in resultgas.f
!
         v(2,nodem)=Pt2zPt1_c
!
         Qred=dabs(xflow)*dsqrt(T1)/(A*P1)
         if (crit) then
            xflow=0.5*inv*Qred_crit*P1*A/dsqrt(T1)
!
            if(lakon(nelem)(2:6).eq.'GAPII') then
               call ts_calc(xflow,T1,P1,kappa,r,a,Ts1,icase)
               if (inv.eq.1) then
                  v(3,node1)=Ts1
                  v(3,node2)=Ts1
                  v(0,node2)=Ts1*(1.d0+km1/(2*kappa))
               else
                  v(3,node2)=Ts1
                  v(3,node1)=Ts1
                  v(0,node1)=Ts1*(1.d0+km1/(2*kappa))
               endif
            endif
         elseif(Qred.gt.Qred_crit) then
            xflow=0.5*inv*Qred_crit*P1*A/dsqrt(T1)
         else
            xflow=inv*Qred*P1*A/dsqrt(T1)
         endif
!
      elseif (iflag.eq.2)then
!
         numf=5
         crit=.false.
!
         pi=4.d0*datan(1.d0)
         e=2.7182818d0
!
         kappa=(cp/(cp-R))
         km1=kappa-1.d0
         kp1=kappa+1.d0
         kdkm1=kappa/km1
         kdkp1=kappa/kp1
!
         index=ielprop(nelem)
         A=prop(index+1)
         d=prop(index+2)
         l=prop(index+3)
         if(l.lt.0d0) then
            l_neg=l
            l=abs(l)
         else
            l_neg=l
         endif
         ks=prop(index+4)
         if(lakon(nelem)(2:6).eq.'GAPIA') then
            icase=0
         elseif(lakon(nelem)(2:6).eq.'GAPII') then
            icase=1
         endif
         form_fact=prop(index+5)
         xflow_oil=prop(index+6)
         k_oil=int(prop(index+7))
!
         pt1=v(2,node1)
         pt2=v(2,node2)
         xflow=v(1,nodem)*iaxial
!
         if(xflow.ge.0d0) then
            inv=1
            xflow=v(1,nodem)*iaxial
            Tt1=v(0,node1)+physcon(1)
            Tt2=v(0,node2)+physcon(1)
!
            call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase)
!
            call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase)
!
            nodef(1)=node1
            nodef(2)=node1
            nodef(3)=nodem
            nodef(4)=node2
            nodef(5)=node2
         else
            inv=-1
            pt1=v(2,node2)
            pt2=v(2,node1)
            xflow=-v(1,nodem)*iaxial
            Tt1=v(0,node2)+physcon(1)
            Tt2=v(0,node1)+physcon(1)
            call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase)
!
            call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase)
!
            nodef(1)=node2
            nodef(2)=node2
            nodef(3)=nodem
            nodef(4)=node1
            nodef(5)=node1
         endif
!
         idirf(1)=2
         idirf(2)=0
         idirf(3)=1
         idirf(4)=2
         idirf(5)=0
!
         pt2zpt1=pt2/pt1
!
!     calculation of the dynamic viscosity
!
         if(xflow_oil.ne.0d0) then
!
            if((k_oil.lt.0).or.(k_oil.gt.12)) then
               write(*,*) '*ERROR:in gaspipe.f'
               write(*,*) ' using two phase flow'
               write(*,*) ' the type of oil is not defined'
               write(*,*) ' check element ',nelem,' definition'
               write(*,*) ' Current calculation stops here'
               call exit(201)
            else
               call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow,
     &              xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop,
     &              v,dvi,cp,r,k_oil,phi,lambda,nshcon,nrhcon,
     &              shcon,rhcon,ntmat_,mi)
               lambda=lambda*phi
            endif
!
!     for pure air
!
         else
            if(dabs(dvi).lt.1E-30) then
               kgas=0
               call dynamic_viscosity(kgas,T1,dvi)
            endif
!
            reynolds=dabs(xflow)*d/(dvi*a)
!
            phi=1.d0
            call friction_coefficient(l_neg,d,ks,reynolds,form_fact,
     &           lambda)
         endif
!
         call pt2zpt1_crit(pt2,pt1,Tt1,Tt2,lambda,kappa,r,l,d,A,iflag,
     &     inv,pt2zpt1_c,qred_crit,crit,qred_max1,icase)
!
         if(dabs(xflow)*dsqrt(Tt1)/(A*Pt1).gt.qred_max1) then
            crit=.true.
         endif
!
!     definition of the coefficients
!
         lld=lambda*l/d
!
         if(.not.crit) then
!
            T_moy=0.5d0*(T1+T2)
            T2dTt2=T2/Tt2
            Tt2dT2=1.d0/T2dTt2
            X_T2dTt2=T2dTt2**(2*kdkm1)
            T1dTt1=T1/Tt1
            Tt1dT1=1.d0/T1dTt1
            X_T1dTt1=T1dTt1**(2*kdkm1)
!
            X2_den=pt2**2*X_T2dTt2
            X2=t2**2/X2_den
            X1_den=pt1**2*X_T1dTt1
            X1=T1**2/X1_den
!
            ln=log(Pt2zPt1*(T2dTt2/T1dTt1)**kdkm1)
!
            m2r2d2a2=xflow**2*R**2/(2*A**2)
!
            C1=2.d0*cp*A**2*X1_den*(1.d0-2.d0*kdkm1*(Tt1dT1-1.d0))
     &           +2.d0*xflow**2*R**2*T1
!
            C2=2.d0*cp*A**2*X2_den*(1.d0-2.d0*kdkm1*(Tt2dT2-1.d0))
     &           +2.d0*xflow**2*R**2*T2
!
            B1=-2.d0*m2r2d2a2*(1.d0-kdkm1)*T1/X1_den*(1.d0-0.5d0*lld)
     &           +0.5d0*R*(ln-kdkm1*(T2+T1)/T1)
!
            B2=2.d0*m2r2d2a2*(1.d0-kdkm1)*T2/X2_den*(1.d0+0.5d0*lld)
     &           +0.5d0*R*(ln+kdkm1*(T2+T1)/T2)
!
!     residual
!
            f=(m2r2d2a2*(X2*(1.d0+0.5d0*lld)-X1*(1.d0-0.5d0*lld))
     &           +R*T_moy*ln
     &           +b2/c2*(2*cp*A**2*(Tt2-T2)*X2_den-xflow**2*R**2*T2**2)
     &           +b1/c1*(2*cp*A**2*(Tt1-T1)*X1_den-xflow**2*R**2*T1**2))
!
!     pressure node1
!
            df(1)=(2.d0*m2r2d2a2*X1/pt1*(1.d0-0.5d0*lld)
     &           -R*T_moy/pt1
     &           +B1/C1*(4.d0*cp*A**2*(Tt1-T1)*pt1*X_T1dTt1))
!
!     temperature node1
!
            df(2)=(-2.d0*m2r2d2a2*(kdkm1/Tt1*X1)*(1.d0-0.5d0*lld)
     &           +r*kdkm1*T_moy/Tt1
     &          +b1/c1*(2*cp*A*A*X1_den*(1.d0-2.d0*kdkm1*(Tt1-T1)/Tt1)))
!
!     mass flow
!
            df(3)=(inv*xflow*R**2/a**2
     &           *(X2*(1.d0+0.5d0*lld)-X1*(1.d0-0.5d0*lld))
     &           +B2/C2*(-2.d0*inv*xflow*R*R*T2**2.d0)
     &           +B1/C1*(-2.d0*inv*xflow*R*R*T1**2.d0))
!
!     pressure node2
!
            df(4)=(-2*m2r2d2a2*X2/pt2*(1.d0+0.5d0*lld)
     &           +R*T_moy/pt2
     &           +B2/C2*(4.d0*cp*A*A*(Tt2-T2)*pt2*X_T2dTt2))
!
!     temperature node2
!
            df(5)=(2.d0*m2r2d2a2*(kdkm1/Tt2*X2)*(1.d0+0.5d0*lld)
     &           -r*kdkm1*T_moy/Tt2
     &          +b2/c2*(2*cp*A*A*X2_den*(1.d0-2.d0*kdkm1*(Tt2-T2)/Tt2)))
!
         else
!
            pt1=pt2/pt2zpt1_c
            f=xflow*dsqrt(Tt1)/pt1-A*qred_crit
!
!     pressure node1
!
            df(1)=-xflow*dsqrt(Tt1)/pt1**2
!
!     temperature node1
!
            df(2)=0.5d0*xflow/(pt1*dsqrt(Tt1))
!
!     mass flow
!
            df(3)=inv*dsqrt(Tt1)/pt1
!
!     pressure node2
!
            df(4)=0.d0
!
!     temperature node2
!
            df(5)=0.d0
!
         endif
!
      elseif(iflag.eq.3) then

         pi=4.d0*datan(1.d0)
         e=2.7182818d0
!
         kappa=(cp/(cp-R))
         km1=kappa-1.d0
         kp1=kappa+1.d0
         kdkm1=kappa/km1
         kdkp1=kappa/kp1
!
         index=ielprop(nelem)
         A=prop(index+1)
!
         d=prop(index+2)
!
         l=prop(index+3)
         if(l.lt.0d0) then
            l_neg=l
            l=abs(l)
         else
            l_neg=l
         endif
         ks=prop(index+4)
         if(lakon(nelem)(2:6).eq.'GAPIA') then
            icase=0
         elseif(lakon(nelem)(2:6).eq.'GAPII') then
            icase=1
         endif
         form_fact=prop(index+5)
         xflow_oil=prop(index+6)
         k_oil=int(prop(index+7))
!
         pt1=v(2,node1)
         pt2=v(2,node2)
!
         if(xflow.ge.0d0) then
            inv=1
            xflow=v(1,nodem)*iaxial
            Tt1=v(0,node1)+physcon(1)
            Tt2=v(0,node2)+physcon(1)
!
            call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase)
!
            call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase)
!
         else
            inv=-1
            pt1=v(2,node2)
            pt2=v(2,node1)
            xflow=-v(1,nodem)*iaxial
            Tt1=v(0,node2)+physcon(1)
            Tt2=v(0,node1)+physcon(1)
!
            call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase)
            call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase)
!
            nodef(1)=node2
            nodef(2)=node2
            nodef(3)=nodem
            nodef(4)=node1
            nodef(5)=node1
         endif
!
         pt2zpt1=pt2/pt1
!
!     calculation of the dynamic viscosity
!
         if(dabs(dvi).lt.1E-30) then
            kgas=0
            call dynamic_viscosity(kgas,T1,dvi)
         endif
         reynolds=dabs(xflow)*d/(dvi*a)
         if(reynolds.lt.100.d0) then
            reynolds= 100.d0
         endif
!
!     definition of the friction coefficient for 2 phase flows and pure air
!
!     Lockhart-Martinelli method
!
         if(lakon(nelem)(7:7).eq.'F') then
!
            if((k_oil.lt.0).or.(k_oil.gt.12)) then
               write(*,*) '*ERROR:in gaspipe.f'
               write(*,*) ' using two phase flow'
               write(*,*) ' the type of oil is not defined'
               write(*,*) ' check element ',nelem,' definition'
               write(*,*) ' Current calculation stops here'
               call exit(201)
            elseif(xflow_oil.eq.0) then
               write(*,*) '*WARNING:in gaspipe.f'
               write(*,*) ' using two phase flow'
               write(*,*) ' the oil mass flow rate is NULL'
               write(*,*) ' check element ',nelem,' definition'
               write(*,*) ' Only pure air is considered'
               phi=1
               call friction_coefficient(l_neg,d,ks,reynolds,form_fact,
     &              lambda)
            else
               call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow,
     &              xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop,
     &              v,dvi,cp,r,k_oil,phi,lambda,nshcon,nrhcon,
     &              shcon,rhcon,ntmat_,mi)
               lambda=lambda*phi
            endif
!
!     for pure air
!
         else
            phi=1.d0
            call friction_coefficient(l_neg,d,ks,reynolds,form_fact,
     &           lambda)
         endif
!
         call pt2zpt1_crit(pt2,pt1,Tt1,Tt2,lambda,kappa,r,l,d,A,iflag,
     &     inv,pt2zpt1_c,qred_crit,crit,qred_max1,icase)
!
!     definition of the coefficients
!
         M1=dsqrt(2/km1*((Tt1/T1)-1))
         M2=dsqrt(2/km1*((Tt2/T2)-1))

         write(1,*) ''
         write(1,55) 'In line',int(nodem/100),' from node',node1,
     &' to node', node2,':   air massflow rate= ',xflow,'kg/s',
     &', oil massflow rate= ',xflow_oil,'kg/s'
 55      FORMAT(1X,A,I6.3,A,I6.3,A,I6.3,A,F9.6,A,A,F9.6,A)
!
         if(inv.eq.1) then
            write(1,53)'       Inlet node ',node1,':    Tt1= ',Tt1,
     &           'K, Ts1= ',T1,'K, Pt1= ',Pt1/1E5,
     &           'Bar, M1= ',M1
            write(1,*)'             element W    ',set(nelem+numf)(1:20)
            write(1,57)'             eta=',dvi,'kg/(m*s), Re= '
     &           ,reynolds,', Phi= ',phi,', lambda= ',lambda,
     &           ', lambda*l/d= ',lambda*l/d,', zeta= ',phi*lambda*l/d
            write(1,53)'       Outlet node ',node2,'    Tt2= ',Tt2,
     &           'K, Ts2= ',T2,'K, Pt2= ',Pt2/1e5,
     &           'Bar, M2= ',M2
!
         else if(inv.eq.-1) then
            write(1,53)'       Inlet node ',node2,':    Tt1= ',Tt1,
     &           'K, Ts1= ',T1,'K, Pt1= ',Pt1/1E5,
     &           'Bar, M1= ',M1
            write(1,*)'             element W    ',set(nelem+numf)(1:20)
            write(1,57)'             eta= ',dvi,'kg/(m*s), Re= '
     &           ,reynolds,' ,Phi= ',phi,', lambda= ',lambda,
     &           ', lambda*l/d= ',lambda*l/d,', zeta= ',phi*lambda*l/d
            write(1,53)'       Outlet node ',node1,'    Tt2= ',Tt2,
     &           'K, Ts2= ',T2,'K, Pt2=',Pt2/1e5,
     &           'Bar, M2= ',M2
         endif
      endif

 53   FORMAT(1X,A,I6.3,A,f6.1,A,f6.1,A,f9.5,A,f8.5)
 57   FORMAT(1X,A,G11.4,A,G11.4,A,f8.5,A,f8.5,A,f8.5,A,f8.5)
!
      xflow=xflow/iaxial
      df(3)=df(3)*iaxial
!
      return
      end


subroutine  VEGVEL(init_vel, PSLCALINIT)
  use simsphere_mod
  implicit none

  real :: SGMA
  integer(kind=1) :: init_vel
  real :: PES, RHOCP, SIGALF, CDL, PI, SDL, rhg, RMRATIODIF, RHA, QSTA
  real :: XLEFN, TFN

  integer :: PSLCALINIT

!      INCLUDE 'modvars.h'

  PES = ( XLAI / 2.0 ) + 1
  RHOCP = CP * PS1 * 100 / ( R * TAF )
  SIGALF = 1 - 0.5 / ( 0.5 + XLAI ) * EXP( -XLAI**2 / 8 )

!     CDL IS THE DRAG COEFFICIENT FOR THE LEAF
!     KEL'S FORMULATION

  CDL = 0.08
  PI = 3.1416

  SDL = XLAI/VEGHEIGHT
  UAF = USTAR * SQRT (PES/(CDL * SDL))

  chf = 0.011 * SQRT(UAF/WIDTH)*(XLAI/PES)

  IF (CHF < 0.001) CHF = 0.001

  RAF = 1 / ( CHF )

!      CHG = ( 1 - SIGALF ) * USTAR**2 / UAF
!        Kell's chg
        chg = Karman**2*uaf/(alog(vegheight*100/0.7))**2
!       Add surface layer resistance to internal air resistance and recompute conductance
  rhg = 1/chg + rtranw
  chg = 1/rhg

!     FOLLOWING IS KEL'S FORMULATION FROM GOUDRIAAN
!     TO GET CHA

!      ALEN = 2 * ((3 * WIDTH**2) / (4 * PI * XLAI/(VEGHEIGHT/2)))
!     /        ** (0.3333)
!     AKCAN = ALEN * 0.5 * UAF
!      RHA = VEGHEIGHT / (2 * AKCAN)
!      CHA = 1 / RHA
!       Above is outdated formulae from Kell. Use old method

  cha = ustar**2 / (uten - uaf )

  IF (CHA <= 0.001) CHA = 0.001

! Convert Q to ELTL and EA.

  QSTF = 10**( 6.1989 - ( 2353 / TF ) )
  SGMA = RHOCP / 0.666
  RMRATIODIF = QSTF - QAF
  IF (RMRATIODIF <= 0) RMRATIODIF = .0001
  VFL = (RMRATIODIF) * PS1 / 0.622

! Call Deardorff (D) or Carlson/Lynn formulation for RST.
! Note RST is actually RF because it contains a cuticular resistance (RCUT).

  IF (STMTYPE == 'D') THEN  ! Deardorff Formulation
    RS = RMIN * (800.0 / (1.0+SOL) + (1.2 * WILT/                       &
         (0.9*W2G+0.1*WGG))**2) ! Stomatal Resistance

    RST = RS * RCUT / (RS + RCUT) * PES / XLAI ! Total Leaf/Canopy Resistance

  ELSE IF (STMTYPE == 'L') THEN ! Lynn and Carlson
    CALL PSLCAL (SGMA, PES, PSLCALINIT)

    RL = RS * RCUT / ( RS + RCUT )   ! Leaf Resistance
    RST = RL * PES / XLAI    ! Total Leaf/Canopy Resistance

  ELSE IF (STMTYPE == 'B') THEN ! Ball-Berry
    CALL BALL (PES, RHA)

    RL = RS * RCUT / ( RS + RCUT )   ! Leaf Resistance
    RST = RL * PES / XLAI    ! Total Leaf/Canopy Resistance

  END IF

  QSTA = 10**( 6.1989 - ( 2353 / TA ) )
  XLEFN = DENS * LE * RMRATIODIF / ( RST + RAF )

!    Average TF and XLEF after initial time step.

  IF (init_vel == 1) THEN
    TF = TAF + ( RNETF - XLEFN ) / (CHF * DENS * CP)
    XLEF = XLEFN
    init_vel = 2
  ELSE
    XLEF = ( XLEF + XLEFN ) / 2
    TFN = TAF + ( RNETF - XLEFN ) / (CHF * DENS * CP)
    TF = (TF + TFN) / 2
  END IF

  RETURN
END


! params.f90
!
!>  The model parameters module.
!
!> @copyright
!> 2015-2020 Lesley De Cruz & Jonathan Demaeyer.
!> See LICENSE.txt for license information.
!
!---------------------------------------------------------------------------
!
!
!---------------------------------------------------------------------------

MODULE params

  IMPLICIT NONE

  PUBLIC

  !> The subclass containing the physical parameters of the model.
  TYPE, PUBLIC :: PhysicsConfiguration
    REAL(KIND=8) :: n         !< \f$n = 2 L_y / L_x\f$ - Aspect ratio
    REAL(KIND=8) :: phi0      !< Latitude in radian
    REAL(KIND=8) :: rra       !< Earth radius
    REAL(KIND=8) :: sig0      !< \f$\sigma_0\f$ - Non-dimensional static stability of the atmosphere.
    REAL(KIND=8) :: k         !< Bottom atmospheric friction coefficient.
    REAL(KIND=8) :: kp        !< \f$k'\f$ - Internal atmospheric friction coefficient.
    REAL(KIND=8) :: r         !< Frictional coefficient at the bottom of the ocean.
    REAL(KIND=8) :: d         !< Merchanical coupling parameter between the ocean and the atmosphere.
    REAL(KIND=8) :: f0        !< \f$f_0\f$ - Coriolis parameter
    REAL(KIND=8) :: gp        !< \f$g'\f$Reduced gravity
    REAL(KIND=8) :: H         !< Depth of the active water layer of the ocean.
    REAL(KIND=8) :: phi0_npi  !< Latitude exprimed in fraction of pi.

    REAL(KIND=8) :: lambda    !< \f$\lambda\f$ - Sensible + turbulent heat exchange between the ocean and the atmosphere.
    REAL(KIND=8) :: Co        !< \f$C_a\f$ - Constant short-wave radiation of the ocean.
    REAL(KIND=8) :: Go        !< \f$\gamma_o\f$ - Specific heat capacity of the ocean.
    REAL(KIND=8) :: Ca        !< \f$C_a\f$ - Constant short-wave radiation of the atmosphere.
    REAL(KIND=8) :: To0       !< \f$T_o^0\f$ -  Stationary solution for the 0-th order ocean temperature.
    REAL(KIND=8) :: Ta0       !< \f$T_a^0\f$ -  Stationary solution for the 0-th order atmospheric temperature.
    REAL(KIND=8) :: epsa      !< \f$\epsilon_a\f$ - Emissivity coefficient for the grey-body atmosphere.
    REAL(KIND=8) :: Ga        !< \f$\gamma_a\f$ - Specific heat capacity of the atmosphere.
    REAL(KIND=8) :: RR        !< \f$R\f$ - Gas constant of dry air

    REAL(KIND=8) :: scale     !< \f$L_y = L \, \pi\f$ - The characteristic space scale.
    REAL(KIND=8) :: pi        !< \f$\pi\f$
    REAL(KIND=8) :: LR        !< \f$L_R\f$ - Rossby deformation radius
    REAL(KIND=8) :: G         !< \f$\gamma\f$
    REAL(KIND=8) :: rp        !< \f$r'\f$ - Frictional coefficient at the bottom of the ocean.
    REAL(KIND=8) :: dp        !< \f$d'\f$ - Non-dimensional mechanical coupling parameter between the ocean and the atmosphere.
    REAL(KIND=8) :: kd        !< \f$k_d\f$ - Non-dimensional bottom atmospheric friction coefficient.
    REAL(KIND=8) :: kdp       !< \f$k'_d\f$ - Non-dimensional internal atmospheric friction coefficient.

    REAL(KIND=8) :: Cpo       !< \f$C'_a\f$ - Non-dimensional constant short-wave radiation of the ocean.
    REAL(KIND=8) :: Lpo       !< \f$\lambda'_o\f$ - Non-dimensional sensible + turbulent heat exchange from ocean to atmosphere.
    REAL(KIND=8) :: Cpa       !< \f$C'_a\f$ - Non-dimensional constant short-wave radiation of the atmosphere. @remark Cpa acts on psi1-psi3, not on theta.
    REAL(KIND=8) :: Lpa       !< \f$\lambda'_a\f$ - Non-dimensional sensible + turbulent heat exchange from atmosphere to ocean.
    REAL(KIND=8) :: sBpo      !< \f$\sigma'_{B,o}\f$ - Long wave radiation lost by ocean to atmosphere & space.
    REAL(KIND=8) :: sBpa      !< \f$\sigma'_{B,a}\f$ - Long wave radiation from atmosphere absorbed by ocean.
    REAL(KIND=8) :: LSBpo     !< \f$S'_{B,o}\f$ - Long wave radiation from ocean absorbed by atmosphere.
    REAL(KIND=8) :: LSBpa     !< \f$S'_{B,a}\f$ - Long wave radiation lost by atmosphere to space & ocean.
    REAL(KIND=8) :: L         !< \f$L\f$ - Domain length scale
    REAL(KIND=8) :: sc        !< Ratio of surface to atmosphere temperature.
    REAL(KIND=8) :: sB        !< Stefan–Boltzmann constant
    REAL(KIND=8) :: betp      !< \f$\beta'\f$ - Non-dimensional beta parameter

    REAL(KIND=8) :: nua=0.D0  !< Dissipation in the atmosphere
    REAL(KIND=8) :: nuo=0.D0  !< Dissipation in the ocean

    REAL(KIND=8) :: nuap      !< Non-dimensional dissipation in the atmosphere
    REAL(KIND=8) :: nuop      !< Non-dimensional dissipation in the ocean
    LOGICAL :: initialized = .FALSE.
  CONTAINS
    PROCEDURE :: init => init_physics_nml
  END TYPE PhysicsConfiguration

  !> The subclass containing the integration parameters.
  TYPE, PUBLIC :: IntegrationParameters
    REAL(KIND=8) :: t_trans   !< Transient time period
    REAL(KIND=8) :: t_run     !< Effective intergration time (length of the generated trajectory)
    REAL(KIND=8) :: dt        !< Integration time step
    REAL(KIND=8) :: tw        !< Write all variables every tw time units
    REAL(KIND=8) :: tw_snap   !< Write a snapshot every tw_snap time units
    LOGICAL :: writeout       !< Write to file boolean
    LOGICAL :: initialized = .FALSE.
  CONTAINS
    PROCEDURE :: init => init_int_params_nml
  END TYPE IntegrationParameters

  !> The subclass containing the modes parameters.
  TYPE, PUBLIC :: ModesConfiguration
    INTEGER :: nboc   !< Number of atmospheric blocks
    INTEGER :: nbatm  !< Number of oceanic blocks
    INTEGER, DIMENSION(:,:), ALLOCATABLE :: oms   !< Ocean mode selection array
    INTEGER, DIMENSION(:,:), ALLOCATABLE :: ams   !< Atmospheric mode selection array
    INTEGER :: natm=0 !< Number of atmospheric basis functions
    INTEGER :: noc=0  !< Number of oceanic basis functions
    INTEGER :: ndim   !< Number of variables (dimension of the model)
    LOGICAL :: initialized = .FALSE.
  CONTAINS
    PROCEDURE :: init => init_modeselection_nml
    PROCEDURE :: clean => delete_modes_config
  END TYPE ModesConfiguration

  !> The general class holding the model configuration.
  TYPE, PUBLIC :: ModelConfiguration
    TYPE(PhysicsConfiguration) :: physics
    TYPE(ModesConfiguration) :: modes
    TYPE(IntegrationParameters) :: integration
    LOGICAL :: initialized = .FALSE.
  CONTAINS
    PROCEDURE :: init => init_model_config
    PROCEDURE :: clean => clean_model_config
  END TYPE ModelConfiguration

CONTAINS

  !> Subroutine to initialize the model configuration with NML files. Reads the physical parameters and mode selection from the namelist.
  !> @param[in,out] model_config Model configuration object
  !> @param[in] physics_nml Physical parameters namelist filename
  !> @param[in] mode_nml Modes configuration namelist filename
  !> @param[in] int_nml Numerical integration parameters namelist filename
  !> @remark If no NML filenames are provided, it will assume that the standard filenames of the model NML have to be used (e.g. "params.nml", "modeselection.nml" and "int_params.nml").
  SUBROUTINE init_model_config(model_config, physics_nml, mode_nml, int_nml)
    CLASS(ModelConfiguration), INTENT(INOUT) :: model_config
    CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: physics_nml
    CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: mode_nml
    CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: int_nml

    IF (present(physics_nml)) THEN
      CALL model_config%physics%init(physics_nml)
    ELSE
      CALL model_config%physics%init
    END IF

    IF (present(mode_nml)) THEN
      CALL model_config%modes%init(mode_nml)
    ELSE
      CALL model_config%modes%init
    END IF

    IF (present(int_nml)) THEN
      CALL model_config%integration%init(int_nml)
    ELSE
      CALL model_config%integration%init
    END IF

    IF ((model_config%physics%initialized).AND.(model_config%modes%initialized).AND.(model_config%integration%initialized)) THEN
      model_config%initialized = .TRUE.
    END IF

  END SUBROUTINE init_model_config

  !> Subroutine to clean the model configuraion object.
  !> @param[in,out] model_config Model configuration object
  SUBROUTINE clean_model_config(model_config)
    CLASS(ModelConfiguration), INTENT(INOUT) :: model_config

    CALL model_config%modes%clean
    model_config%initialized = .FALSE.
    model_config%integration%initialized = .FALSE.
    model_config%physics%initialized = .FALSE.

  END SUBROUTINE clean_model_config

  ! Subroutine to initialize the physical parameters subclass.
  SUBROUTINE init_physics_nml(physics_config, filename)
    CLASS(PhysicsConfiguration), INTENT(INOUT), TARGET :: physics_config
    CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: filename
    CHARACTER(LEN=*), PARAMETER :: fs='params.nml'

    TYPE(PhysicsConfiguration), POINTER :: phys

    REAL(KIND=8) :: n
    REAL(KIND=8) :: rra
    REAL(KIND=8) :: sig0
    REAL(KIND=8) :: k
    REAL(KIND=8) :: kp
    REAL(KIND=8) :: r
    REAL(KIND=8) :: d
    REAL(KIND=8) :: f0
    REAL(KIND=8) :: gp
    REAL(KIND=8) :: H
    REAL(KIND=8) :: phi0_npi

    REAL(KIND=8) :: lambda
    REAL(KIND=8) :: Co
    REAL(KIND=8) :: Go
    REAL(KIND=8) :: Ca
    REAL(KIND=8) :: To0
    REAL(KIND=8) :: Ta0
    REAL(KIND=8) :: epsa
    REAL(KIND=8) :: Ga
    REAL(KIND=8) :: RR

    REAL(KIND=8) :: scale
    REAL(KIND=8) :: sc
    REAL(KIND=8) :: sB

    REAL(KIND=8) :: nua=0.D0
    REAL(KIND=8) :: nuo=0.D0

    NAMELIST /aoscale/  scale,f0,n,rra,phi0_npi
    NAMELIST /oparams/  gp,r,H,d,nuo
    NAMELIST /aparams/  k,kp,sig0,nua
    NAMELIST /toparams/ Go,Co,To0
    NAMELIST /taparams/ Ga,Ca,epsa,Ta0
    NAMELIST /otparams/ sc,lambda,RR,sB

    IF (present(filename)) THEN
      OPEN(8, file=filename, status='OLD', recl=80, delim='APOSTROPHE')
    ELSE
      OPEN(8, file=fs, status='OLD', recl=80, delim='APOSTROPHE')
    END IF

    READ(8,nml=aoscale)
    READ(8,nml=oparams)
    READ(8,nml=aparams)
    READ(8,nml=toparams)
    READ(8,nml=taparams)
    READ(8,nml=otparams)
    CLOSE(8)

    phys => physics_config

    phys%n = n
    phys%rra = rra
    phys%sig0 = sig0
    phys%k = k
    phys%kp = kp
    phys%r = r
    phys%d = d
    phys%f0 = f0
    phys%gp = gp
    phys%H = H
    phys%phi0_npi = phi0_npi

    phys%lambda = lambda
    phys%Co = Co
    phys%Go = Go
    phys%Ca = Ca
    phys%To0 = To0
    phys%Ta0 = Ta0
    phys%epsa = epsa
    phys%Ga = Ga
    phys%RR = RR

    phys%scale = scale

    phys%sc = sc
    phys%sB = sB

    phys%nua = nua
    phys%nuo = nuo

    ! Some general parameters (Domain, beta, gamma, coupling) !
    !---------------------------------------------------------!

    phys%pi=dacos(-1.D0)
    phys%L=phys%scale/phys%pi
    phys%phi0=phys%phi0_npi*phys%pi
    phys%LR=sqrt(phys%gp*phys%H)/phys%f0
    phys%G=-phys%L**2/phys%LR**2
    phys%betp=phys%L/phys%rra*cos(phys%phi0)/sin(phys%phi0)
    phys%rp=phys%r/phys%f0
    phys%dp=phys%d/phys%f0
    phys%kd=phys%k*2
    phys%kdp=phys%kp

    ! DERIVED QUANTITIES                                  !
    !-----------------------------------------------------!

    phys%Cpo=phys%Co/(phys%Go*phys%f0) * phys%RR/(phys%f0**2*phys%L**2)
    phys%Lpo=phys%lambda/(phys%Go*phys%f0)
    phys%Cpa=phys%Ca/(phys%Ga*phys%f0) * phys%RR/(phys%f0**2*phys%L**2)/2 ! Cpa acts on psi1-psi3, not on theta
    phys%Lpa=phys%lambda/(phys%Ga*phys%f0)
    phys%sBpo=4*phys%sB*phys%To0**3/(phys%Go*phys%f0) ! long wave radiation lost by ocean to atmosphere space
    phys%sBpa=8*phys%epsa*phys%sB*phys%Ta0**3/(phys%Go*phys%f0) ! long wave radiation from atmosphere absorbed by ocean
    phys%LSBpo=2*phys%epsa*phys%sB*phys%To0**3/(phys%Ga*phys%f0) ! long wave radiation from ocean absorbed by atmosphere
    phys%LSBpa=8*phys%epsa*phys%sB*phys%Ta0**3/(phys%Ga*phys%f0) ! long wave radiation lost by atmosphere to space & ocea
    phys%nuap=phys%nua/(phys%f0*phys%L**2)
    phys%nuop=phys%nuo/(phys%f0*phys%L**2)

    phys%initialized = .TRUE.

  END SUBROUTINE init_physics_nml

  ! Subroutine to initialize the modes parameters subclass.
  SUBROUTINE init_modeselection_nml(mode_selection, filename)
    CLASS(ModesConfiguration), INTENT(INOUT) :: mode_selection
    CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: filename
    CHARACTER(LEN=*), PARAMETER :: fs='modeselection.nml'

    INTEGER :: nboc
    INTEGER :: nbatm
    INTEGER, DIMENSION(:,:), ALLOCATABLE :: oms
    INTEGER, DIMENSION(:,:), ALLOCATABLE :: ams

    INTEGER :: i
    INTEGER :: AllocStat
    INTEGER, DIMENSION(2) :: s

    NAMELIST /numblocs/ nboc,nbatm
    NAMELIST /modeselection/ oms,ams

    IF (present(filename)) THEN
      OPEN(8, file=filename, status='OLD', recl=80, delim='APOSTROPHE')
    ELSE
      OPEN(8, file=fs, status='OLD', recl=80, delim='APOSTROPHE')
    END IF
    READ(8,nml=numblocs)

    ALLOCATE(oms(nboc,2),ams(nbatm,2), STAT=AllocStat)
    IF (AllocStat /= 0) THEN
      PRINT*, "*** init_modeselection_nml: Problem with allocation! ***"
      STOP "Exiting ..."
    END IF

    READ(8,nml=modeselection)
    CLOSE(8)

    mode_selection%nboc = nboc
    mode_selection%nbatm = nbatm

    IF (allocated(mode_selection%oms)) DEALLOCATE(mode_selection%oms)
    ALLOCATE(mode_selection%oms(nboc,2), STAT=AllocStat)
    IF (AllocStat /= 0) THEN
      PRINT*, "*** init_modeselection_nml: Problem with allocation! ***"
      STOP "Exiting ..."
    END IF

    IF (allocated(mode_selection%ams)) DEALLOCATE(mode_selection%ams)
    ALLOCATE(mode_selection%ams(nbatm,2), STAT=AllocStat)
    IF (AllocStat /= 0) THEN
      PRINT*, "*** init_modeselection_nml: Problem with allocation! ***"
      STOP "Exiting ..."
    END IF

    mode_selection%oms = oms
    mode_selection%ams = ams

    ! Computation of the dimension of the atmospheric         !
    ! and oceanic components                                  !
    !---------------------------------------------------------!

    mode_selection%natm=0
    DO i=1,nbatm
      IF (ams(i,1)==1) THEN
        mode_selection%natm=mode_selection%natm+3
      ELSE
        mode_selection%natm=mode_selection%natm+2
      ENDIF
    ENDDO
    s=shape(oms)
    mode_selection%noc=s(1)

    mode_selection%ndim=2*mode_selection%natm+2*mode_selection%noc

    DEALLOCATE(ams, oms)
    mode_selection%initialized = .TRUE.

  END SUBROUTINE init_modeselection_nml

  ! Subroutine to delete a modes configuration
  SUBROUTINE delete_modes_config(mode_selection)
    CLASS(ModesConfiguration), INTENT(INOUT) :: mode_selection

    IF (allocated(mode_selection%oms)) DEALLOCATE(mode_selection%oms)
    IF (allocated(mode_selection%ams)) DEALLOCATE(mode_selection%ams)

    mode_selection%natm=0
    mode_selection%noc=0
    mode_selection%ndim=0
    mode_selection%natm=0
    mode_selection%nboc=0
    mode_selection%nbatm=0

    mode_selection%initialized = .FALSE.

  END SUBROUTINE delete_modes_config

  ! Subroutine to initialize the integration parameters subclass.
  SUBROUTINE init_int_params_nml(i_params, filename)
    CLASS(IntegrationParameters), INTENT(INOUT) :: i_params
    CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: filename
    CHARACTER(LEN=*), PARAMETER :: fs='int_params.nml'

    REAL(KIND=8) :: t_trans
    REAL(KIND=8) :: t_run
    REAL(KIND=8) :: dt
    REAL(KIND=8) :: tw
    REAL(KIND=8) :: tw_snap
    LOGICAL :: writeout

    NAMELIST /int_params/ t_trans,t_run,dt,tw,tw_snap,writeout

    IF (present(filename)) THEN
      OPEN(8, file=filename, status='OLD', recl=80, delim='APOSTROPHE')
    ELSE
      OPEN(8, file=fs, status='OLD', recl=80, delim='APOSTROPHE')
    END IF

    READ(8,nml=int_params)
    CLOSE(8)

    i_params%t_trans = t_trans
    i_params%t_run = t_run
    i_params%dt = dt
    i_params%tw = tw
    i_params%tw_snap = tw_snap
    i_params%writeout = writeout

    i_params%initialized = .TRUE.

  END SUBROUTINE init_int_params_nml

END MODULE params


      PROGRAM PDINVDRIVER
*
*  -- ScaLAPACK testing driver (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*  Purpose
*  =======
*
*  PDINVDRIVER is the main test program for the DOUBLE PRECISION
*  SCALAPACK matrix inversion routines.  This test driver computes the
*  inverse of different kind of matrix and tests the results.
*
*  The program must be driven by a short data file. An annotated example
*  of a data file can be obtained by deleting the first 3 characters
*  from the following 14 lines:
*  'ScaLAPACK Matrix Inversion Testing input file'
*  'PVM machine.'
*  'INV.out'                   output file name (if any)
*  6                           device out
*  5                           number of matrix types (next line)
*  'GEN' 'UTR' 'LTR' 'UPD' LPD' GEN, UTR, LTR, UPD, LPD
*  4                           number of problems sizes
*  1000 2000 3000 4000         values of N
*  3                           number of NB's
*  4 30 35                     values of NB
*  2                           number of process grids (ordered P & Q)
*  4 2                         values of P
*  4 4                         values of Q
*  1.0                         threshold
*
*  Internal Parameters
*  ===================
*
*  TOTMEM   INTEGER, default = 2000000
*           TOTMEM is a machine-specific parameter indicating the
*           maximum amount of available memory in bytes.
*           The user should customize TOTMEM to his platform.  Remember
*           to leave room in memory for the operating system, the BLACS
*           buffer, etc.  For example, on a system with 8 MB of memory
*           per process (e.g., one processor on an Intel iPSC/860), the
*           parameters we use are TOTMEM=6200000 (leaving 1.8 MB for OS,
*           code, BLACS buffer, etc).  However, for PVM, we usually set
*           TOTMEM = 2000000.  Some experimenting with the maximum value
*           of TOTMEM may be required.
*
*  INTGSZ   INTEGER, default = 4 bytes.
*  DBLESZ   INTEGER, default = 8 bytes.
*           INTGSZ and DBLESZ indicate the length in bytes on the
*           given platform for an integer and a double precision real.
*  MEM      DOUBLE PRECISION array, dimension ( TOTMEM / DBLESZ )
*
*           All arrays used by SCALAPACK routines are allocated from
*           this array and referenced by pointers.  The integer IPA,
*           for example, is a pointer to the starting element of MEM for
*           the matrix A.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
     $                   LLD_, MB_, M_, NB_, N_, RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
     $                     CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
     $                     RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
      INTEGER            DBLESZ, INTGSZ, MEMSIZ, NTESTS, TOTMEM
      DOUBLE PRECISION   PADVAL, ZERO
      PARAMETER          ( DBLESZ = 8, INTGSZ = 4, TOTMEM = 2000000,
     $                     MEMSIZ = TOTMEM / DBLESZ, NTESTS = 20,
     $                     PADVAL = -9923.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      CHARACTER          UPLO
      CHARACTER*3        MTYP
      CHARACTER*6        PASSED
      CHARACTER*80       OUTFILE
      LOGICAL            CHECK
      INTEGER            I, IAM, IASEED, ICTXT, IMIDPAD, INFO, IPA,
     $                   IPPIV, IPREPAD, IPOSTPAD, IPIW, IPW, ITEMP, J,
     $                   K, KTESTS, KPASS, KFAIL, KSKIP, L, LCM, LIPIV,
     $                   LIWORK, LWORK, MYCOL, MYROW, N, NB, NGRIDS,
     $                   NMAT, NMTYP, NNB, NOUT, NP, NPCOL, NPROCS,
     $                   NPROW, NQ, WORKIINV, WORKINV, WORKSIZ
      REAL               THRESH
      DOUBLE PRECISION   ANORM, FRESID, NOPS, RCOND, TMFLOPS
*     ..
*     .. Local Arrays ..
      CHARACTER*3        MATTYP( NTESTS )
      INTEGER            DESCA( DLEN_ ), IERR( 1 ), NBVAL( NTESTS ),
     $                   NVAL( NTESTS ), PVAL( NTESTS ),
     $                   QVAL( NTESTS )
      DOUBLE PRECISION   MEM( MEMSIZ ), CTIME( 2 ), WTIME( 2 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_BARRIER, BLACS_EXIT, BLACS_GET,
     $                   BLACS_GRIDEXIT, BLACS_GRIDINFO, BLACS_GRIDINIT,
     $                   BLACS_PINFO, DESCINIT, IGSUM2D, PDCHEKPAD,
     $                   PDFILLPAD, PDGETRF, PDGETRI,
     $                   PDINVCHK, PDINVINFO, PDLASET,
     $                   PDMATGEN, PDPOTRF, PDPOTRI,
     $                   PDTRTRI, SLBOOT, SLCOMBINE, SLTIMER
*     ..
*     .. External Functions ..
      LOGICAL            LSAMEN
      INTEGER            ICEIL, ILCM, NUMROC
      DOUBLE PRECISION   PDLANGE, PDLANSY, PDLANTR
      EXTERNAL           ICEIL, ILCM, LSAMEN, NUMROC, PDLANGE,
     $                   PDLANSY, PDLANTR
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MAX, MOD
*     ..
*     .. Data Statements ..
      DATA               KTESTS, KPASS, KFAIL, KSKIP /4*0/
*     ..
*     .. Executable Statements ..
*
*     Get starting information
*
      CALL BLACS_PINFO( IAM, NPROCS )
      IASEED = 100
      CALL PDINVINFO( OUTFILE, NOUT, NMTYP, MATTYP, NTESTS, NMAT, NVAL,
     $                NTESTS, NNB, NBVAL, NTESTS, NGRIDS, PVAL, NTESTS,
     $                QVAL, NTESTS, THRESH, MEM, IAM, NPROCS )
      CHECK = ( THRESH.GE.0.0E+0 )
*
*     Loop over the different matrix types
*
      DO 40 I = 1, NMTYP
*
         MTYP = MATTYP( I )
*
*        Print headings
*
         IF( IAM.EQ.0 ) THEN
            WRITE( NOUT, FMT = * )
            IF( LSAMEN( 3, MTYP, 'GEN' ) ) THEN
               WRITE( NOUT, FMT = 9986 )
     $                'A is a general matrix.'
            ELSE IF( LSAMEN( 3, MTYP, 'UTR' ) ) THEN
               WRITE( NOUT, FMT = 9986 )
     $               'A is an upper triangular matrix.'
            ELSE IF( LSAMEN( 3, MTYP, 'LTR' ) ) THEN
               WRITE( NOUT, FMT = 9986 )
     $               'A is a lower triangular matrix.'
            ELSE IF( LSAMEN( 3, MTYP, 'UPD' ) ) THEN
               WRITE( NOUT, FMT = 9986 )
     $               'A is a symmetric positive definite matrix.'
               WRITE( NOUT, FMT = 9986 )
     $               'Only the upper triangular part will be '//
     $               'referenced.'
            ELSE IF( LSAMEN( 3, MTYP, 'LPD' ) ) THEN
               WRITE( NOUT, FMT = 9986 )
     $               'A is a symmetric positive definite matrix.'
               WRITE( NOUT, FMT = 9986 )
     $               'Only the lower triangular part will be '//
     $               'referenced.'
            END IF
            WRITE( NOUT, FMT = * )
            WRITE( NOUT, FMT = 9995 )
            WRITE( NOUT, FMT = 9994 )
            WRITE( NOUT, FMT = * )
         END IF
*
*        Loop over different process grids
*
         DO 30 J = 1, NGRIDS
*
            NPROW = PVAL( J )
            NPCOL = QVAL( J )
*
*           Make sure grid information is correct
*
            IERR( 1 ) = 0
            IF( NPROW.LT.1 ) THEN
               IF( IAM.EQ.0 )
     $            WRITE( NOUT, FMT = 9999 ) 'GRID', 'nprow', NPROW
               IERR( 1 ) = 1
            ELSE IF( NPCOL.LT.1 ) THEN
               IF( IAM.EQ.0 )
     $            WRITE( NOUT, FMT = 9999 ) 'GRID', 'npcol', NPCOL
               IERR( 1 ) = 1
            ELSE IF( NPROW*NPCOL.GT.NPROCS ) THEN
               IF( IAM.EQ.0 )
     $            WRITE( NOUT, FMT = 9998 ) NPROW*NPCOL, NPROCS
               IERR( 1 ) = 1
            END IF
*
            IF( IERR( 1 ).GT.0 ) THEN
               IF( IAM.EQ.0 )
     $            WRITE( NOUT, FMT = 9997 ) 'grid'
               KSKIP = KSKIP + 1
               GO TO 30
            END IF
*
*           Define process grid
*
            CALL BLACS_GET( -1, 0, ICTXT )
            CALL BLACS_GRIDINIT( ICTXT, 'Row-major', NPROW, NPCOL )
            CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
*
*           Go to bottom of loop if this case doesn't use my process
*
            IF( MYROW.GE.NPROW .OR. MYCOL.GE.NPCOL )
     $         GO TO 30
*
            DO 20 K = 1, NMAT
*
               N = NVAL( K )
*
*              Make sure matrix information is correct
*
               IERR( 1 ) = 0
               IF( N.LT.1 ) THEN
                  IF( IAM.EQ.0 )
     $               WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N
                  IERR( 1 ) = 1
               END IF
*
*              Make sure no one had error
*
               CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 )
*
               IF( IERR( 1 ).GT.0 ) THEN
                  IF( IAM.EQ.0 )
     $               WRITE( NOUT, FMT = 9997 ) 'matrix'
                  KSKIP = KSKIP + 1
                  GO TO 20
               END IF
*
*              Loop over different blocking sizes
*
               DO 10 L = 1, NNB
*
                  NB = NBVAL( L )
*
*                 Make sure nb is legal
*
                  IERR( 1 ) = 0
                  IF( NB.LT.1 ) THEN
                     IERR( 1 ) = 1
                     IF( IAM.EQ.0 )
     $                  WRITE( NOUT, FMT = 9999 ) 'NB', 'NB', NB
                  END IF
*
*                 Check all processes for an error
*
                  CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1,
     $                          0 )
*
                  IF( IERR( 1 ).GT.0 ) THEN
                     IF( IAM.EQ.0 )
     $                  WRITE( NOUT, FMT = 9997 ) 'NB'
                     KSKIP = KSKIP + 1
                     GO TO 10
                  END IF
*
*                 Padding constants
*
                  NP = NUMROC( N, NB, MYROW, 0, NPROW )
                  NQ = NUMROC( N, NB, MYCOL, 0, NPCOL )
                  IF( CHECK ) THEN
                     IPREPAD  = MAX( NB, NP )
                     IMIDPAD  = NB
                     IPOSTPAD = MAX( NB, NQ )
                  ELSE
                     IPREPAD  = 0
                     IMIDPAD  = 0
                     IPOSTPAD = 0
                  END IF
*
*                 Initialize the array descriptor for the matrix A
*
                  CALL DESCINIT( DESCA, N, N, NB, NB, 0, 0, ICTXT,
     $                           MAX( 1, NP ) + IMIDPAD, IERR( 1 ) )
*
*                 Check all processes for an error
*
                  CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1,
     $                          0 )
*
                  IF( IERR( 1 ).LT.0 ) THEN
                     IF( IAM.EQ.0 )
     $                  WRITE( NOUT, FMT = 9997 ) 'descriptor'
                     KSKIP = KSKIP + 1
                     GO TO 10
                  END IF
*
*                 Assign pointers into MEM for ScaLAPACK arrays, A is
*                 allocated starting at position MEM( IPREPAD+1 )
*
                  IPA = IPREPAD+1
*
                  LCM = ILCM( NPROW, NPCOL )
                  IF( LSAMEN( 3, MTYP, 'GEN' ) ) THEN
*
*                    Pivots are needed by LU factorization
*
                     IPPIV = IPA + DESCA( LLD_ ) * NQ + IPOSTPAD +
     $                       IPREPAD
                     LIPIV = ICEIL( INTGSZ * ( NP + NB ), DBLESZ )
                     IPW = IPPIV + LIPIV + IPOSTPAD + IPREPAD
*
                     LWORK = MAX( 1, NP * DESCA( NB_ ) )
                     WORKINV = LWORK + IPOSTPAD
*
*                    Figure the amount of workspace required by the
*                    general matrix inversion
*
                     IF( NPROW.EQ.NPCOL ) THEN
                        LIWORK = NQ + DESCA( NB_ )
                     ELSE
*
* change the integer workspace needed for PDGETRI
*                        LIWORK = MAX( DESCA( NB_ ), DESCA( MB_ ) *
*     $                           ICEIL( ICEIL( DESCA( LLD_ ),
*     $                                  DESCA( MB_ ) ), LCM / NPROW ) )
*     $                                  + NQ
                         LIWORK = NUMROC( DESCA( M_ ) +
     $                  DESCA( MB_ ) * NPROW
     $                  + MOD ( 1 - 1, DESCA( MB_ ) ), DESCA ( NB_ ),
     $                  MYCOL, DESCA( CSRC_ ), NPCOL ) +
     $                  MAX ( DESCA( MB_ ) * ICEIL ( ICEIL(
     $                  NUMROC( DESCA( M_ ) + DESCA( MB_ ) * NPROW,
     $                  DESCA( MB_ ), MYROW, DESCA( RSRC_ ), NPROW ),
     $                  DESCA( MB_ ) ), LCM / NPROW ), DESCA( NB_ ) )
*
                     END IF
                     WORKIINV = ICEIL( LIWORK*INTGSZ, DBLESZ ) +
     $                          IPOSTPAD
                     IPIW = IPW + WORKINV + IPREPAD
                     WORKSIZ = WORKINV + IPREPAD + WORKIINV
*
                  ELSE
*
*                    No pivots or workspace needed for triangular or
*                    symmetric positive definite matrices.
*
                     IPW = IPA + DESCA( LLD_ ) * NQ + IPOSTPAD + IPREPAD
                     WORKSIZ = 1 + IPOSTPAD
*
                  END IF
*
                  IF( CHECK ) THEN
*
*                    Figure amount of work space for the norm
*                    computations
*
                     IF( LSAMEN( 3, MTYP, 'GEN'       ).OR.
     $                   LSAMEN( 2, MTYP( 2:3 ), 'TR' ) ) THEN
                        ITEMP = NQ
                     ELSE
                        ITEMP = 2 * NQ + NP
                        IF( NPROW.NE.NPCOL ) THEN
                           ITEMP = ITEMP +
     $                             NB * ICEIL( ICEIL( NP, NB ),
     $                                         LCM / NPROW )
                        END IF
                     END IF
                     WORKSIZ = MAX( WORKSIZ-IPOSTPAD, ITEMP )
*
*                    Figure the amount of workspace required by the
*                    checking routine
*
                     WORKSIZ = MAX( WORKSIZ, 2 * NB * MAX( 1, NP ) ) +
     $                         IPOSTPAD
*
                  END IF
*
*                 Check for adequate memory for problem size
*
                  IERR( 1 ) = 0
                  IF( IPW+WORKSIZ.GT.MEMSIZ ) THEN
                     IF( IAM.EQ.0 )
     $                  WRITE( NOUT, FMT = 9996 ) 'inversion',
     $                         ( IPW + WORKSIZ ) * DBLESZ
                     IERR( 1 ) = 1
                  END IF
*
*                 Check all processes for an error
*
                  CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1,
     $                          0 )
*
                  IF( IERR( 1 ).GT.0 ) THEN
                     IF( IAM.EQ.0 )
     $                  WRITE( NOUT, FMT = 9997 ) 'MEMORY'
                     KSKIP = KSKIP + 1
                     GO TO 10
                  END IF
*
                  IF( LSAMEN( 3, MTYP, 'GEN'       ).OR.
     $                LSAMEN( 2, MTYP( 2:3 ), 'TR' ) ) THEN
*
*                    Generate a general diagonally dominant matrix A
*
                     CALL PDMATGEN( ICTXT, 'N', 'D', DESCA( M_ ),
     $                              DESCA( N_ ), DESCA( MB_ ),
     $                              DESCA( NB_ ), MEM( IPA ),
     $                              DESCA( LLD_ ), DESCA( RSRC_ ),
     $                              DESCA( CSRC_ ), IASEED, 0, NP, 0,
     $                              NQ, MYROW, MYCOL, NPROW, NPCOL )
*
                  ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'PD' ) ) THEN
*
*                    Generate a symmetric positive definite matrix
*
                     CALL PDMATGEN( ICTXT, 'S', 'D', DESCA( M_ ),
     $                              DESCA( N_ ), DESCA( MB_ ),
     $                              DESCA( NB_ ), MEM( IPA ),
     $                              DESCA( LLD_ ), DESCA( RSRC_ ),
     $                              DESCA( CSRC_ ), IASEED, 0, NP, 0,
     $                              NQ, MYROW, MYCOL, NPROW, NPCOL )
*
                  END IF
*
*                 Zeros not-referenced part of A, if any.
*
                  IF( LSAMEN( 1, MTYP, 'U' ) ) THEN
*
                     UPLO = 'U'
                     CALL PDLASET( 'Lower', N-1, N-1, ZERO, ZERO,
     $                             MEM( IPA ), 2, 1, DESCA )
*
                  ELSE IF( LSAMEN( 1, MTYP, 'L' ) ) THEN
*
                     UPLO = 'L'
                     CALL PDLASET( 'Upper', N-1, N-1, ZERO, ZERO,
     $                             MEM( IPA ), 1, 2, DESCA )
*
                  ELSE
*
                     UPLO = 'G'
*
                  END IF
*
*                 Need 1-norm of A for checking
*
                  IF( CHECK ) THEN
*
                     CALL PDFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ),
     $                               DESCA( LLD_ ), IPREPAD, IPOSTPAD,
     $                               PADVAL )
                     CALL PDFILLPAD( ICTXT, WORKSIZ-IPOSTPAD, 1,
     $                               MEM( IPW-IPREPAD ),
     $                               WORKSIZ-IPOSTPAD, IPREPAD,
     $                               IPOSTPAD, PADVAL )
*
                     IF( LSAMEN( 3, MTYP, 'GEN' ) ) THEN
*
                        CALL PDFILLPAD( ICTXT, LIPIV, 1,
     $                                 MEM( IPPIV-IPREPAD ), LIPIV,
     $                                 IPREPAD, IPOSTPAD, PADVAL )
                        ANORM = PDLANGE( '1', N, N, MEM( IPA ), 1, 1,
     $                                   DESCA, MEM( IPW ) )
                        CALL PDCHEKPAD( ICTXT, 'PDLANGE', NP, NQ,
     $                                  MEM( IPA-IPREPAD ),
     $                                  DESCA( LLD_ ),
     $                                  IPREPAD, IPOSTPAD, PADVAL )
                        CALL PDCHEKPAD( ICTXT, 'PDLANGE',
     $                                  WORKSIZ-IPOSTPAD, 1,
     $                                  MEM( IPW-IPREPAD ),
     $                                  WORKSIZ-IPOSTPAD,
     $                                  IPREPAD, IPOSTPAD, PADVAL )
                        CALL PDFILLPAD( ICTXT, WORKINV-IPOSTPAD, 1,
     $                                  MEM( IPW-IPREPAD ),
     $                                  WORKINV-IPOSTPAD,
     $                                  IPREPAD, IPOSTPAD, PADVAL )
                        CALL PDFILLPAD( ICTXT, WORKIINV-IPOSTPAD, 1,
     $                                 MEM( IPIW-IPREPAD ),
     $                                 WORKIINV-IPOSTPAD, IPREPAD,
     $                                 IPOSTPAD, PADVAL )
                     ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'TR' ) ) THEN
*
                        ANORM = PDLANTR( '1', UPLO, 'Non unit', N, N,
     $                                   MEM( IPA ), 1, 1, DESCA,
     $                                   MEM( IPW ) )
                        CALL PDCHEKPAD( ICTXT, 'PDLANTR', NP, NQ,
     $                                  MEM( IPA-IPREPAD ),
     $                                  DESCA( LLD_ ),
     $                                  IPREPAD, IPOSTPAD, PADVAL )
                        CALL PDCHEKPAD( ICTXT, 'PDLANTR',
     $                                  WORKSIZ-IPOSTPAD, 1,
     $                                  MEM( IPW-IPREPAD ),
     $                                  WORKSIZ-IPOSTPAD,
     $                                  IPREPAD, IPOSTPAD, PADVAL )
*
                     ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'PD' ) ) THEN
*
                        ANORM = PDLANSY( '1', UPLO, N, MEM( IPA ), 1, 1,
     $                                   DESCA, MEM( IPW ) )
                        CALL PDCHEKPAD( ICTXT, 'PDLANSY', NP, NQ,
     $                                  MEM( IPA-IPREPAD ),
     $                                  DESCA( LLD_ ),
     $                                  IPREPAD, IPOSTPAD, PADVAL )
                        CALL PDCHEKPAD( ICTXT, 'PDLANSY',
     $                                  WORKSIZ-IPOSTPAD, 1,
     $                                  MEM( IPW-IPREPAD ),
     $                                  WORKSIZ-IPOSTPAD,
     $                                  IPREPAD, IPOSTPAD, PADVAL )
*
                     ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'SY' ) ) THEN
*
                        CALL PDFILLPAD( ICTXT, LIPIV, 1,
     $                                  MEM( IPPIV-IPREPAD ), LIPIV,
     $                                  IPREPAD, IPOSTPAD, PADVAL )
                        ANORM = PDLANSY( '1', UPLO, N, MEM( IPA ), 1, 1,
     $                                   DESCA, MEM( IPW ) )
                        CALL PDCHEKPAD( ICTXT, 'PDLANSY', NP, NQ,
     $                                  MEM( IPA-IPREPAD ),
     $                                  DESCA( LLD_ ),
     $                                  IPREPAD, IPOSTPAD, PADVAL )
                        CALL PDCHEKPAD( ICTXT, 'PDLANSY',
     $                                  WORKSIZ-IPOSTPAD, 1,
     $                                  MEM( IPW-IPREPAD ),
     $                                  WORKSIZ-IPOSTPAD,
     $                                  IPREPAD,IPOSTPAD, PADVAL )
*
                     END IF
*
                  END IF
*
                  CALL SLBOOT()
                  CALL BLACS_BARRIER( ICTXT, 'All' )
*
                  IF( LSAMEN( 3, MTYP, 'GEN' ) ) THEN
*
*                    Perform LU factorization
*
                     CALL SLTIMER( 1 )
                     CALL PDGETRF( N, N, MEM( IPA ), 1, 1, DESCA,
     $                             MEM( IPPIV ), INFO )
                     CALL SLTIMER( 1 )
*
                     IF( CHECK ) THEN
*
*                       Check for memory overwrite
*
                        CALL PDCHEKPAD( ICTXT, 'PDGETRF', NP, NQ,
     $                                  MEM( IPA-IPREPAD ),
     $                                  DESCA( LLD_ ),
     $                                  IPREPAD, IPOSTPAD, PADVAL )
                        CALL PDCHEKPAD( ICTXT, 'PDGETRF', LIPIV, 1,
     $                                  MEM( IPPIV-IPREPAD ), LIPIV,
     $                                  IPREPAD, IPOSTPAD, PADVAL )
                     END IF
*
*                    Perform the general matrix inversion
*
                     CALL SLTIMER( 2 )
                     CALL PDGETRI( N, MEM( IPA ), 1, 1, DESCA,
     $                             MEM( IPPIV ), MEM( IPW ), LWORK,
     $                             MEM( IPIW ), LIWORK, INFO )
                     CALL SLTIMER( 2 )
*
                     IF( CHECK ) THEN
*
*                       Check for memory overwrite
*
                        CALL PDCHEKPAD( ICTXT, 'PDGETRI', NP, NQ,
     $                                  MEM( IPA-IPREPAD ),
     $                                  DESCA( LLD_ ),
     $                                  IPREPAD, IPOSTPAD, PADVAL )
                        CALL PDCHEKPAD( ICTXT, 'PDGETRI', LIPIV, 1,
     $                                  MEM( IPPIV-IPREPAD ), LIPIV,
     $                                  IPREPAD, IPOSTPAD, PADVAL )
                        CALL PDCHEKPAD( ICTXT, 'PDGETRI',
     $                                  WORKIINV-IPOSTPAD, 1,
     $                                  MEM( IPIW-IPREPAD ),
     $                                  WORKIINV-IPOSTPAD,
     $                                  IPREPAD, IPOSTPAD, PADVAL )
                        CALL PDCHEKPAD( ICTXT, 'PDGETRI',
     $                                  WORKINV-IPOSTPAD, 1,
     $                                  MEM( IPW-IPREPAD ),
     $                                  WORKINV-IPOSTPAD,
     $                                  IPREPAD, IPOSTPAD, PADVAL )
                     END IF
*
                  ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'TR' ) ) THEN
*
*                    Perform the general matrix inversion
*
                     CALL SLTIMER( 2 )
                     CALL PDTRTRI( UPLO, 'Non unit', N, MEM( IPA ), 1,
     $                             1, DESCA, INFO )
                     CALL SLTIMER( 2 )
*
                     IF( CHECK ) THEN
*
*                       Check for memory overwrite
*
                        CALL PDCHEKPAD( ICTXT, 'PDTRTRI', NP, NQ,
     $                                  MEM( IPA-IPREPAD ),
     $                                  DESCA( LLD_ ),
     $                                  IPREPAD, IPOSTPAD, PADVAL )
                     END IF
*
                  ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'PD' ) ) THEN
*
*                    Perform Cholesky factorization
*
                     CALL SLTIMER( 1 )
                     CALL PDPOTRF( UPLO, N, MEM( IPA ), 1, 1, DESCA,
     $                             INFO )
                     CALL SLTIMER( 1 )
*
                     IF( CHECK ) THEN
*
*                       Check for memory overwrite
*
                        CALL PDCHEKPAD( ICTXT, 'PDPOTRF', NP, NQ,
     $                                  MEM( IPA-IPREPAD ),
     $                                  DESCA( LLD_ ),
     $                                  IPREPAD, IPOSTPAD, PADVAL )
                     END IF
*
*                    Perform the symmetric positive definite matrix
*                    inversion
*
                     CALL SLTIMER( 2 )
                     CALL PDPOTRI( UPLO, N, MEM( IPA ), 1, 1, DESCA,
     $                             INFO )
                     CALL SLTIMER( 2 )
*
                     IF( CHECK ) THEN
*
*                       Check for memory overwrite
*
                        CALL PDCHEKPAD( ICTXT, 'PDPOTRI', NP, NQ,
     $                                  MEM( IPA-IPREPAD ),
     $                                  DESCA( LLD_ ),
     $                                  IPREPAD, IPOSTPAD, PADVAL )
                     END IF
*
                  END IF
*
                  IF( CHECK ) THEN
*
                     CALL PDFILLPAD( ICTXT, WORKSIZ-IPOSTPAD, 1,
     $                               MEM( IPW-IPREPAD ),
     $                               WORKSIZ-IPOSTPAD, IPREPAD,
     $                               IPOSTPAD, PADVAL )
*
*                    Compute fresid = || inv(A)*A-I ||
*
                     CALL PDINVCHK( MTYP, N, MEM( IPA ), 1, 1, DESCA,
     $                              IASEED, ANORM, FRESID, RCOND,
     $                              MEM( IPW ) )
*
*                    Check for memory overwrite
*
                     CALL PDCHEKPAD( ICTXT, 'PDINVCHK', NP, NQ,
     $                               MEM( IPA-IPREPAD ),
     $                               DESCA( LLD_ ),
     $                               IPREPAD, IPOSTPAD, PADVAL )
                     CALL PDCHEKPAD( ICTXT, 'PDINVCHK',
     $                               WORKSIZ-IPOSTPAD, 1,
     $                               MEM( IPW-IPREPAD ),
     $                               WORKSIZ-IPOSTPAD, IPREPAD,
     $                               IPOSTPAD, PADVAL )
*
*                    Test residual and detect NaN result
*
                     IF( FRESID.LE.THRESH .AND. INFO.EQ.0 .AND.
     $                   ( (FRESID-FRESID) .EQ. 0.0D+0 ) ) THEN
                        KPASS = KPASS + 1
                        PASSED = 'PASSED'
                     ELSE
                        KFAIL = KFAIL + 1
                        IF( INFO.GT.0 ) THEN
                           PASSED = 'SINGUL'
                        ELSE
                           PASSED = 'FAILED'
                        END IF
                     END IF
*
                  ELSE
*
*                    Don't perform the checking, only the timing
*                    operation
*
                     KPASS = KPASS + 1
                     FRESID = FRESID - FRESID
                     PASSED = 'BYPASS'
*
                  END IF
*
*                 Gather maximum of all CPU and WALL clock timings
*
                  CALL SLCOMBINE( ICTXT, 'All', '>', 'W', 2, 1, WTIME )
                  CALL SLCOMBINE( ICTXT, 'All', '>', 'C', 2, 1, CTIME )
*
*                 Print results
*
                  IF( MYROW.EQ.0 .AND. MYCOL.EQ.0  ) THEN
*
                     IF( LSAMEN( 3, MTYP, 'GEN' ) ) THEN
*
*                       2/3 N^3 - 1/2 N^2 flops for LU factorization
*
                        NOPS = ( 2.0D+0 / 3.0D+0 )*( DBLE( N )**3 ) -
     $                         ( 1.0D+0 / 2.0D+0 )*( DBLE( N )**2 )
*
*                       4/3 N^3 - N^2 flops for inversion
*
                        NOPS = NOPS +
     $                         ( 4.0D+0 / 3.0D+0 ) * ( DBLE( N )**3 ) -
     $                         DBLE( N )**2
*
                     ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'TR' ) ) THEN
*
*                       1/3 N^3 + 2/3 N flops for triangular inversion
*
                        CTIME(1) = 0.0D+0
                        WTIME(1) = 0.0D+0
                        NOPS = ( 1.0D+0 / 3.0D+0 ) * ( DBLE( N )**3 ) +
     $                         ( 2.0D+0 / 3.0D+0 ) * ( DBLE( N ) )
*
                     ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'PD' ) ) THEN
*
*                       1/3 N^3 + 1/2 N^2 flops for Cholesky
*                       factorization
*
                        NOPS = ( 1.0D+0 / 3.0D+0 ) * ( DBLE( N )**3 ) +
     $                         ( 1.0D+0 / 2.0D+0 ) * ( DBLE( N )**2 )
*
*                       2/3 N^3  + 1/2 N^2 flops for Cholesky inversion
*
                        NOPS = NOPS +
     $                         ( 2.0D+0 / 3.0D+0 ) * ( DBLE( N )**3 ) +
     $                         ( 1.0D+0 / 2.0D+0 ) * ( DBLE( N )**2 )
*
                     END IF
*
*                    Figure total megaflops -- factorization and
*                    inversion, for WALL and CPU time, and print
*                    output.
*
*                    Print WALL time if machine supports it
*
                     IF( WTIME( 1 ) + WTIME( 2 ) .GT. 0.0D+0 ) THEN
                        TMFLOPS = NOPS /
     $                            ( ( WTIME( 1 )+WTIME( 2 ) ) * 1.0D+6 )
                     ELSE
                        TMFLOPS = 0.0D+0
                     END IF
*
                     IF( WTIME( 2 ) .GE. 0.0D+0 )
     $                  WRITE( NOUT, FMT = 9993 ) 'WALL', N, NB, NPROW,
     $                         NPCOL, WTIME( 1 ), WTIME( 2 ), TMFLOPS,
     $                         RCOND, FRESID, PASSED
*
*                    Print CPU time if machine supports it
*
                     IF( CTIME( 1 ) + CTIME( 2 ) .GT. 0.0D+0 ) THEN
                        TMFLOPS = NOPS /
     $                            ( ( CTIME( 1 )+CTIME( 2 ) ) * 1.0D+6 )
                     ELSE
                        TMFLOPS = 0.0D+0
                     END IF
*
                     IF( CTIME( 2 ) .GE. 0.0D+0 )
     $                  WRITE( NOUT, FMT = 9993 ) 'CPU ', N, NB, NPROW,
     $                         NPCOL, CTIME( 1 ), CTIME( 2 ), TMFLOPS,
     $                         RCOND, FRESID, PASSED
                  END IF
*
   10          CONTINUE
*
   20       CONTINUE
*
            CALL BLACS_GRIDEXIT( ICTXT )
*
   30    CONTINUE
*
   40 CONTINUE
*
*     Print out ending messages and close output file
*
      IF( IAM.EQ.0 ) THEN
         KTESTS = KPASS + KFAIL + KSKIP
         WRITE( NOUT, FMT = * )
         WRITE( NOUT, FMT = 9992 ) KTESTS
         IF( CHECK ) THEN
            WRITE( NOUT, FMT = 9991 ) KPASS
            WRITE( NOUT, FMT = 9989 ) KFAIL
         ELSE
            WRITE( NOUT, FMT = 9990 ) KPASS
         END IF
         WRITE( NOUT, FMT = 9988 ) KSKIP
         WRITE( NOUT, FMT = * )
         WRITE( NOUT, FMT = * )
         WRITE( NOUT, FMT = 9987 )
         IF( NOUT.NE.6 .AND. NOUT.NE.0 )
     $      CLOSE ( NOUT )
      END IF
*
      CALL BLACS_EXIT( 0 )
*
 9999 FORMAT( 'ILLEGAL ', A6, ': ', A5, ' = ', I3,
     $        '; It should be at least 1' )
 9998 FORMAT( 'ILLEGAL GRID: nprow*npcol = ', I4, '. It can be at most',
     $        I4 )
 9997 FORMAT( 'Bad ', A6, ' parameters: going on to next test case.' )
 9996 FORMAT( 'Unable to perform ', A, ': need TOTMEM of at least',
     $        I11 )
 9995 FORMAT( 'TIME     N  NB     P     Q Fct Time Inv Time ',
     $        '     MFLOPS    Cond   Resid  CHECK' )
 9994 FORMAT( '---- ----- --- ----- ----- -------- -------- ',
     $        '----------- ------- ------- ------' )
 9993 FORMAT( A4, 1X, I5, 1X, I3, 1X, I5, 1X, I5, 1X, F8.2, 1X, F8.2,
     $        1X, F11.2, 1X, F7.1, 1X, F7.2, 1X, A6 )
 9992 FORMAT( 'Finished ', I6, ' tests, with the following results:' )
 9991 FORMAT( I5, ' tests completed and passed residual checks.' )
 9990 FORMAT( I5, ' tests completed without checking.' )
 9989 FORMAT( I5, ' tests completed and failed residual checks.' )
 9988 FORMAT( I5, ' tests skipped because of illegal input values.' )
 9987 FORMAT( 'END OF TESTS.' )
 9986 FORMAT( A )
*
      STOP
*
*     End of PDINVDRIVER
*
      END


! { dg-do compile }
! { dg-options "-O2 -ftree-loop-distribution -fdump-tree-ldist-all" }

Subroutine PADEC(DKS,DKDS,HVAR,WM,WG,FN,NS,AN,BN,CN,IT)
  IMPLICIT REAL*8 (A-H, O-Z)
  DIMENSION DKS(*),DKDS(*),HVAR(*)
  COMPLEX*16 WM(*),WG(*),FN(*),AN(*),BN(*),CN(*)
  COMPLEX*16 H2,CONST
  COMMON/STRCH/ALP,BET,DH,ZH,UG,VG,T1,T2,DT,TOL,ALPHA ,HAMP,BUMP
  Parameter (F1 = .8333333333333333D0, F2 = .0833333333333333D0)

  SS=DT/(2.0D0)

  do J=2,NS
     BS=SS*DKS(J)*HVAR(J)*HVAR(J)
     AN(J)=F1+2.*BS
     BN(J)=F2-BS
     CN(J)=F2-BS
     H2=WM(J+1)

     if(J.EQ.NS) then
        CONST=CN(J)*H2
     else
        CONST=(0.D0,0.D0)
     endif
     FN(J)=(BS+F2)*(H2)+(F1-2.D0*BS)-CONST
  end do

  return
end Subroutine PADEC

! There are 5 legal partitions in this code.  Based on the data
! locality heuristic, this loop should not be split.

! { dg-final { scan-tree-dump-not "distributed: split to" "ldist" } }


program foo
   integer, parameter :: numdims = 4
   integer :: localcount(numdims), localmap(numdims)

   localCount = (/ 2, 3, 5, 7 /)

!  localMap   (:numDims  ) = (/ 1, (product(localCount(:j)), j = 1, numDims - 1) /)
!  localMap   (:numDims  ) = (/ 1, (product(localCount(:j)), j = 5, 12) /)

   localMap   (:numDims  ) = (/ 1, (product(localCount(:j)), j = 1, numDims - 1) /)
   print *, "localcount=", localcount
   print *, "localmap=", localmap
end


!*****************************************************************************
!
! Rokko: Integrated Interface for libraries of eigenvalue decomposition
!
! Copyright (C) 2012-2020 by Rokko Developers https://github.com/t-sakashita/rokko
!
! Distributed under the Boost Software License, Version 1.0. (See accompanying
! file LICENSE_1_0.txt or copy at http://www.boost.org/license_1_0.txt)
!
!*****************************************************************************

program frank_matrix
  use rokko
  use various_mpi_comm_mod
  implicit none
  integer :: dim
  type(rokko_distributed_matrix) :: mat, Z
  type(rokko_grid) :: grid
  type(rokko_mapping_bc) :: map
  type(rokko_parallel_dense_ev) :: solver
  type(rokko_eigen_vector) :: w
  character(len=:), allocatable :: library, routine
  character(len=:), allocatable :: library_routine, tmp_str
  integer :: comm
  integer :: provided, ierr, myrank, nprocs
  integer :: i

  call MPI_init_thread(MPI_THREAD_MULTIPLE, provided, ierr)
  call MPI_comm_rank(MPI_COMM_WORLD, myrank, ierr)
  call MPI_comm_size(MPI_COMM_WORLD, nprocs, ierr)
  comm = create_cart_comm(mpi_comm_world)

  if (comm /= MPI_COMM_NULL) then
     if (command_argument_count() >= 1) then
        call get_command_argument_deferred(1, library_routine)
     else
        library_routine = rokko_parallel_dense_ev_default_solver()
     endif
     call rokko_split_solver_name(library_routine, library, routine)

     if (command_argument_count() == 2) then
        call get_command_argument_deferred(2, tmp_str)
        read(tmp_str, *) dim
     else
        dim = 10
     endif

     if (myrank == 0) then
        print *,"library = ", library
        print *,"routine = ", routine
        print *,"dimension = ", dim
     endif

     call rokko_construct(solver, library)
     call rokko_construct(grid, comm, rokko_grid_row_major)
     call rokko_default_mapping(solver, dim, grid, map)
     call rokko_construct(mat, map)
     call rokko_construct(Z, map)
     call rokko_construct(w, dim)

     if (myrank == 0) then
        write(*,'("Created ", i0, "x", i0, " size communicator with new cartesian topology")') &
             & rokko_get_nprow(grid), rokko_get_npcol(grid)
     endif

     ! generate frank matrix
     call rokko_frank_matrix_generate(mat)
     call rokko_print(mat)

     call rokko_diagonalize(solver, mat, w, Z)

     if (myrank.eq.0) then
        write(*,'(A)') "Computed Eigenvalues = "
        do i = 1, dim
           write(*,"(f30.20)") rokko_get_elem(w, i)
        enddo
     endif

     call rokko_destruct(mat)
     call rokko_destruct(Z)
     call rokko_destruct(w)
     call rokko_destruct(solver)
     call rokko_destruct(map)
     call rokko_destruct(grid)

     call mpi_comm_free(comm, ierr)
  endif
  call MPI_finalize(ierr)
end program frank_matrix


      SUBROUTINE bksub(ne,nb,jf,k1,k2,c,nci,ncj,nck)
      INTEGER jf,k1,k2,nb,nci,ncj,nck,ne
      REAL c(nci,ncj,nck)
      INTEGER i,im,j,k,kp,nbf
      REAL xx
      nbf=ne-nb
      im=1
      do 13 k=k2,k1,-1
        if (k.eq.k1) im=nbf+1
        kp=k+1
        do 12 j=1,nbf
          xx=c(j,jf,kp)
          do 11 i=im,ne
            c(i,jf,k)=c(i,jf,k)-c(i,j,k)*xx
11        continue
12      continue
13    continue
      do 16 k=k1,k2
        kp=k+1
        do 14 i=1,nb
          c(i,1,k)=c(i+nbf,jf,k)
14      continue
        do 15 i=1,nbf
          c(i+nb,1,k)=c(i,jf,kp)
15      continue
16    continue
      return
      END

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


use BitClass
implicit none

type(Bit_) :: bit
integer(int32) :: i

![000]~[111]
call bit%init(n=3)

! Bit reversal
do i=0,7
    print *, "-----------"
    bit = i
    print *,  bit%int()
    bit = reverse(bit)
    print *,  bit%int()
enddo

end


C   File: array-to-func_03.f
C   This test is an example of passing arrays to a function (subroutine)
C   as arguments once and initialize the array under a single loop.
C
C   The code was sampled from SIR-Gillespie.f

      subroutine update_mean_var(meanS, varS)
      integer, parameter :: Tmax = 100

      double precision, dimension(0:Tmax) :: MeanS, MeanI, MeanR
      double precision, dimension(0:Tmax) :: VarS, VarI, VarR

      integer i

      do i = 0, Tmax
         MeanS(i) = 0
         MeanI(i) = 0.0
         MeanR(i) = 0.0

         VarS(i) = 0.0
         VarI(i) = 0.0
         VarR(i) = 0.0
      end do

      return
      end subroutine update_mean_var

      program main
      implicit none

      integer, parameter :: Tmax = 100
      double precision, dimension(0:Tmax) :: MeanS, MeanI, MeanR
      double precision, dimension(0:Tmax) :: VarS, VarI, VarR

      call update_mean_var(meanS, varS)

      end program main


#include "scalar.fpp"
!=====================================================================!
! Module that contains common procedures for any physical system
! subject to governing equations
!
! Author: Komahan Boopathy (komahan@gatech.edu)
!=====================================================================!

module physics_class

  use function_class, only  : abstract_function

  implicit none

  private
  public :: physics

  !-------------------------------------------------------------------!
  ! Type that models any physical phenomenon
  !-------------------------------------------------------------------!

  type, abstract :: physics

     character(len=20) :: name

     integer                             :: num_design_vars = 0
     integer                             :: num_state_vars  = 0
     type(scalar), dimension(:), allocatable :: x
     class(abstract_function), pointer   :: func => null() ! function of interest

   contains

     ! Constructor and destructor
     procedure :: initialize, finalize

     ! Setters
     procedure :: setFunction
     procedure :: setDesignVars
     procedure :: getNumStateVars

     ! Deferred procedures
     procedure(initial_condition_interface), deferred :: getInitialStates
     procedure(residual_assembly_interface), deferred :: assembleResidual
     procedure(jacobian_assembly_interface), deferred :: assembleJacobian

     procedure(InterfaceGetResidualDVSens), deferred  :: getResidualDVSens
     procedure(InterfaceMapDesignVars), deferred  :: mapDesignVars

  end type physics

  interface

     !----------------------------------------------------------------!
     ! Interface for evaluating the gradient of Residual with respect
     ! to X
     !----------------------------------------------------------------!

     subroutine InterfaceGetResidualDVSens(this, jac, scale, time, x, u, udot, uddot)

       import physics

       class(physics)                         :: this
       type(scalar), intent(inout), dimension(:,:) :: jac
       real(dp), intent(in)                        :: time
       type(scalar), intent(in), dimension(:)      :: x, u, udot, uddot
       type(scalar)                                :: scale

     end subroutine InterfaceGetResidualDVSens

     !----------------------------------------------------------------!
     ! Interface for initialization tasks
     !----------------------------------------------------------------!

     subroutine InterfaceInitialize(this,  x, function)
       import physics
       import abstract_function
       class(physics) :: this
       class(abstract_function), target, OPTIONAL  :: function
       type(scalar), intent(in), dimension(:), OPTIONAl :: x
     end subroutine InterfaceInitialize

     !----------------------------------------------------------------!
     ! Interface for residual assembly at each time step
     !----------------------------------------------------------------!

     subroutine residual_assembly_interface(this, res, time, u, udot, uddot)

       import physics

       class(physics) :: this
       type(scalar), intent(inout), dimension(:) :: res
       real(dp), intent(in) :: time
       type(scalar), intent(in), dimension(:) :: u, udot, uddot

     end subroutine residual_assembly_interface

     !----------------------------------------------------------------!
     ! Interface for jacobian assembly at each time step
     !----------------------------------------------------------------!

     subroutine jacobian_assembly_interface(this, jac, alpha, beta, gamma, &
          & time, u, udot, uddot)

       import physics

       class(physics) :: this
       type(scalar), intent(inout), dimension(:,:) :: jac
       type(scalar), intent(in) :: alpha, beta, gamma
       real(dp), intent(in) :: time
       type(scalar), intent(in), dimension(:) :: u, udot, uddot

     end subroutine jacobian_assembly_interface

     !----------------------------------------------------------------!
     ! Interface for supplying the initial condition to the integrator!
     !----------------------------------------------------------------!

     subroutine initial_condition_interface(this, time, u, udot)

       import physics

       class(physics) :: this
       real(dp), intent(in) :: time
       type(scalar), intent(inout), dimension(:) :: u, udot

     end subroutine initial_condition_interface

     !----------------------------------------------------------------!
     ! Return the number of state variables
     !----------------------------------------------------------------!

     function InterfaceGetNumStateVars(this)
       import physics
       class(physics) :: this
       integer :: InterfaceGetNumStateVars
     end function InterfaceGetNumStateVars

     !-------------------------------------------------------------------!
     ! Map the the design variables into the class variables
     !-------------------------------------------------------------------!

     subroutine InterfaceMapDesignVars(this)
       import physics
       class(physics) :: this
     end subroutine InterfaceMapDesignVars

  end interface

contains

  !===================================================================!
  ! Initialize the system
  !===================================================================!

  subroutine initialize(this, name, num_state_vars, num_design_vars)

    class(physics)      :: this
    character(len=*), intent(in) :: name
    integer, intent(in) :: num_state_vars
    integer, intent(in), OPTIONAL :: num_design_vars

    this % name = name
    this % num_state_vars  = num_state_vars

    if (present(num_design_vars)) then
       this % num_design_vars = num_design_vars
       allocate(this % x(this % num_design_vars))
    end if

  end subroutine initialize

  !===================================================================!
  ! Finalize the allocated variables
  !===================================================================!

  subroutine finalize(this)

    class(physics) :: this

    if ( allocated(this % x) ) deallocate(this % x)

    print*, "Yet to deassociate the function"

  end subroutine finalize

  !-------------------------------------------------------------------!
  ! Set the design varaibles
  !-------------------------------------------------------------------!

  subroutine setDesignVars(this, num_dvs, x)

    class(physics)                    :: this
    type(scalar), intent(in), dimension(:) :: x
    integer, intent(in)               :: num_dvs

    if (this % num_design_vars .ne. size(x)) stop "Error in num_design_vars"

    this % x = x

    call this % mapDesignVars()

  end subroutine setDesignVars

  !===================================================================!
  ! Set the function created into the system                          !
  !===================================================================!

  subroutine setFunction(this, func)

    class(physics)                   :: this
    class(abstract_function), target :: func

    this % func => func

  end subroutine setFunction

  !===================================================================!
  ! Return the number of state variables
  !===================================================================!

  integer function getNumStateVars(this)

    class(physics) :: this

    getNumStateVars = this % num_state_vars

  end function getNumStateVars

end module physics_class