 MODULE GDSWZD_MERCATOR_MOD
!$$$  MODULE DOCUMENTATION BLOCK
!
! $Revision: 74917 $
!
! MODULE:  GDSWZD_MERCATOR_MOD  GDS WIZARD MODULE FOR MERCATOR
!                               CYLINDRICAL GRIDS
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: - CONVERT FROM EARTH TO GRID COORDINATES OR VICE VERSA.
!           - COMPUTE VECTOR ROTATION SINES AND COSINES.
!           - COMPUTE MAP JACOBIANS.
!           - COMPUTE GRID BOX AREA.
!
! PROGRAM HISTORY LOG:
!   2015-01-21  GAYNO   INITIAL VERSION FROM A MERGER OF
!                       ROUTINES GDSWIZ01 AND GDSWZD01.
!   2015-09-17  GAYNO   RENAME MODULE AS "GDSWZD_MERCATOR_MOD"
!
! USAGE:  "USE GDSWZD_MERCATOR_MOD"  THEN CALL THE PUBLIC DRIVER
!         ROUTINE "GDSWZD_MERCATOR".
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 IMPLICIT NONE

 PRIVATE

 PUBLIC                       :: GDSWZD_MERCATOR

 REAL,          PARAMETER     :: PI=3.14159265358979
 REAL,          PARAMETER     :: DPR=180./PI

 REAL                         :: DLON
 REAL                         :: DPHI
 REAL                         :: RERTH

 CONTAINS

 SUBROUTINE GDSWZD_MERCATOR(IGDTNUM,IGDTMPL,IGDTLEN,IOPT,NPTS,FILL, &
                            XPTS,YPTS,RLON,RLAT,NRET, &
                            CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  GDSWZD_MERCATOR   GDS WIZARD FOR MERCATOR CYLINDRICAL
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
!
! ABSTRACT: THIS ROUTINE DECODES THE GRIB 2 GRID DEFINITION
!           TEMPLATE (PASSED IN INTEGER FORM AS DECODED BY THE
!           NCEP G2 LIBRARY) AND RETURNS ONE OF THE FOLLOWING:
!             (IOPT=+1) EARTH COORDINATES OF SELECTED GRID COORDINATES
!             (IOPT=-1) GRID COORDINATES OF SELECTED EARTH COORDINATES
!           WORKS FOR MERCATOR CYLINDRICAL PROJECTIONS.
!           IF THE SELECTED COORDINATES ARE MORE THAN ONE GRIDPOINT
!           BEYOND THE THE EDGES OF THE GRID DOMAIN, THEN THE RELEVANT
!           OUTPUT ELEMENTS ARE SET TO FILL VALUES. THE
!           ACTUAL NUMBER OF VALID POINTS COMPUTED IS RETURNED TOO.
!           OPTIONALLY, THE VECTOR ROTATIONS, MAP JACOBIANS AND
!           THE GRID BOX AREAS MAY BE RETURNED.  TO COMPUTE THE
!           VECTOR ROTATIONS, THE OPTIONAL ARGUMENTS 'SROT' AND 'CROT'
!           MUST BE PRESENT.  TO COMPUTE THE MAP JACOBIANS, THE
!           OPTIONAL ARGUMENTS 'XLON', 'XLAT', 'YLON', 'YLAT' MUST BE
!           PRESENT. TO COMPUTE THE GRID BOX AREAS, THE OPTIONAL
!           ARGUMENT 'AREA' MUST BE PRESENT.
!
! PROGRAM HISTORY LOG:
!   96-04-10  IREDELL
!   96-10-01  IREDELL  PROTECTED AGAINST UNRESOLVABLE POINTS
!   97-10-20  IREDELL  INCLUDE MAP OPTIONS
! 2015-01-21  GAYNO    MERGER OF GDSWIZ01 AND GDSWZD01.  MAKE
!                      CROT,SORT,XLON,XLAT,YLON,YLAT AND AREA
!                      OPTIONAL ARGUMENTS.  MAKE PART OF A MODULE.
!                      MOVE VECTOR ROTATION, MAP JACOBIAN AND GRID
!                      BOX AREA COMPUTATIONS TO SEPARATE SUBROUTINES.
! 2015-07-13  GAYNO    CONVERT TO GRIB 2. REPLACE GRIB 1 KGDS ARRAY
!                      WITH GRIB 2 GRID DEFINITION TEMPLATE ARRAY.
!                      RENAME AS "GDSWZD_MERCATOR".
!
! USAGE:    CALL GDSWZD_MERCATOR(IGDTNUM,IGDTMPL,IGDTLEN,IOPT,NPTS, &
!                                FILL,XPTS,YPTS,RLON,RLAT,NRET, &
!                                CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
!
!   INPUT ARGUMENT LIST:
!     IGDTNUM  - INTEGER GRID DEFINITION TEMPLATE NUMBER.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!                MUST BE "10" FOR MERCATOR GRIDS.
!     IGDTMPL  - INTEGER (IGDTLEN) GRID DEFINITION TEMPLATE ARRAY.
!                CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE FOR SECTION
!                THREE:
!                 (1):  SHAPE OF EARTH, OCTET 15
!                 (2):  SCALE FACTOR OF SPHERICAL EARTH RADIUS,
!                       OCTET 16
!                 (3):  SCALED VALUE OF RADIUS OF SPHERICAL EARTH,
!                       OCTETS 17-20
!                 (4):  SCALE FACTOR OF MAJOR AXIS OF ELLIPTICAL EARTH,
!                       OCTET 21
!                 (5):  SCALED VALUE OF MAJOR AXIS OF ELLIPTICAL EARTH,
!                       OCTETS 22-25
!                 (6):  SCALE FACTOR OF MINOR AXIS OF ELLIPTICAL EARTH,
!                       OCTET 26
!                 (7):  SCALED VALUE OF MINOR AXIS OF ELLIPTICAL EARTH,
!                       OCTETS 27-30
!                 (8):  NUMBER OF POINTS ALONG A PARALLEL, OCTS 31-34
!                 (9):  NUMBER OF POINTS ALONG A MERIDIAN, OCTS 35-38
!                 (10): LATITUDE OF FIRST POINT, OCTETS 39-42
!                 (11): LONGITUDE OF FIRST POINT, OCTETS 43-46
!                 (12): RESOLUTION AND COMPONENT FLAGS, OCTET 47
!                 (13): TANGENT LATITUDE, OCTETS 48-51
!                 (14): LATITUDE OF LAST POINT, OCTETS 52-55
!                 (15): LONGITUDE OF LAST POINT, OCTETS 56-59
!                 (16): SCANNING MODE FLAGS, OCTET 60
!                 (17): ORIENTATION OF GRID, OCTETS 61-64
!                 (18): LONGITUDINAL GRID LENGTH, OCTETS 65-68
!                 (19): LATITUDINAL GRID LENGTH, OCTETS 69-72
!     IGDTLEN  - INTEGER NUMBER OF ELEMENTS (19) OF THE GRID DEFINITION
!                TEMPLATE ARRAY.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IOPT     - INTEGER OPTION FLAG
!                (+1 TO COMPUTE EARTH COORDS OF SELECTED GRID COORDS)
!                (-1 TO COMPUTE GRID COORDS OF SELECTED EARTH COORDS)
!     NPTS     - INTEGER MAXIMUM NUMBER OF COORDINATES
!     FILL     - REAL FILL VALUE TO SET INVALID OUTPUT DATA
!                (MUST BE IMPOSSIBLE VALUE; SUGGESTED VALUE: -9999.)
!     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT>0
!     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT>0
!     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT<0
!                (ACCEPTABLE RANGE: -360. TO 360.)
!     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT<0
!                (ACCEPTABLE RANGE: -90. TO 90.)
!
!   OUTPUT ARGUMENT LIST:
!     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT<0
!     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT<0
!     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT>0
!     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT>0
!     NRET     - INTEGER NUMBER OF VALID POINTS COMPUTED
!     CROT     - REAL, OPTIONAL (NPTS) CLOCKWISE VECTOR ROTATION COSINES
!     SROT     - REAL, OPTIONAL (NPTS) CLOCKWISE VECTOR ROTATION SINES
!                (UGRID=CROT*UEARTH-SROT*VEARTH;
!                 VGRID=SROT*UEARTH+CROT*VEARTH)
!     XLON     - REAL, OPTIONAL (NPTS) DX/DLON IN 1/DEGREES
!     XLAT     - REAL, OPTIONAL (NPTS) DX/DLAT IN 1/DEGREES
!     YLON     - REAL, OPTIONAL (NPTS) DY/DLON IN 1/DEGREES
!     YLAT     - REAL, OPTIONAL (NPTS) DY/DLAT IN 1/DEGREES
!     AREA     - REAL, OPTIONAL (NPTS) AREA WEIGHTS IN M**2
!                (PROPORTIONAL TO THE SQUARE OF THE MAP FACTOR)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER,           INTENT(IN   ) :: IGDTNUM, IGDTLEN
 INTEGER,           INTENT(IN   ) :: IGDTMPL(IGDTLEN)
 INTEGER,           INTENT(IN   ) :: IOPT, NPTS
 INTEGER,           INTENT(  OUT) :: NRET
!
 REAL,              INTENT(IN   ) :: FILL
 REAL,              INTENT(INOUT) :: RLON(NPTS),RLAT(NPTS)
 REAL,              INTENT(INOUT) :: XPTS(NPTS),YPTS(NPTS)
 REAL, OPTIONAL,    INTENT(  OUT) :: CROT(NPTS),SROT(NPTS)
 REAL, OPTIONAL,    INTENT(  OUT) :: XLON(NPTS),XLAT(NPTS)
 REAL, OPTIONAL,    INTENT(  OUT) :: YLON(NPTS),YLAT(NPTS),AREA(NPTS)
!
 INTEGER                          :: ISCAN, JSCAN
 INTEGER                          :: IM, JM, N
!
 LOGICAL                          :: LROT, LMAP, LAREA
!
 REAL                             :: DY, HI, HJ, ECCEN_SQUARED
 REAL                             :: RLAT1, RLON1, RLON2, RLATI
 REAL                             :: XMAX, XMIN, YMAX, YMIN
 REAL                             :: YE
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 IF(PRESENT(CROT)) CROT=FILL
 IF(PRESENT(SROT)) SROT=FILL
 IF(PRESENT(XLON)) XLON=FILL
 IF(PRESENT(XLAT)) XLAT=FILL
 IF(PRESENT(YLON)) YLON=FILL
 IF(PRESENT(YLAT)) YLAT=FILL
 IF(PRESENT(AREA)) AREA=FILL
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! IS THIS A MERCATOR GRID?
 IF(IGDTNUM/=10) THEN
   CALL MERCATOR_ERROR(IOPT,FILL,RLAT,RLON,XPTS,YPTS,NPTS)
   RETURN
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 CALL EARTH_RADIUS(IGDTMPL,IGDTLEN,RERTH,ECCEN_SQUARED)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! ROUTINE ONLY WORKS FOR SPHERICAL EARTHS.
 IF(RERTH<0..OR.ECCEN_SQUARED/=0.0) THEN
   CALL MERCATOR_ERROR(IOPT,FILL,RLAT,RLON,XPTS,YPTS,NPTS)
   RETURN
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 IM=IGDTMPL(8)
 JM=IGDTMPL(9)
 RLAT1=FLOAT(IGDTMPL(10))*1.0E-6
 RLON1=FLOAT(IGDTMPL(11))*1.0E-6
 RLON2=FLOAT(IGDTMPL(15))*1.0E-6
 RLATI=FLOAT(IGDTMPL(13))*1.0E-6
 ISCAN=MOD(IGDTMPL(16)/128,2)
 JSCAN=MOD(IGDTMPL(16)/64,2)
 DY=FLOAT(IGDTMPL(19))*1.0E-3
 HI=(-1.)**ISCAN
 HJ=(-1.)**(1-JSCAN)
 DLON=HI*(MOD(HI*(RLON2-RLON1)-1+3600,360.)+1)/(IM-1)
 DPHI=HJ*DY/(RERTH*COS(RLATI/DPR))
 YE=1-LOG(TAN((RLAT1+90)/2/DPR))/DPHI
 XMIN=0
 XMAX=IM+1
 IF(IM.EQ.NINT(360/ABS(DLON))) XMAX=IM+2
 YMIN=0
 YMAX=JM+1
 NRET=0
 IF(PRESENT(CROT).AND.PRESENT(SROT))THEN
   LROT=.TRUE.
 ELSE
   LROT=.FALSE.
 ENDIF
 IF(PRESENT(XLON).AND.PRESENT(XLAT).AND.PRESENT(YLON).AND.PRESENT(YLAT))THEN
   LMAP=.TRUE.
 ELSE
   LMAP=.FALSE.
 ENDIF
 IF(PRESENT(AREA))THEN
   LAREA=.TRUE.
 ELSE
   LAREA=.FALSE.
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  TRANSLATE GRID COORDINATES TO EARTH COORDINATES
 IF(IOPT.EQ.0.OR.IOPT.EQ.1) THEN
!$OMP PARALLEL DO PRIVATE(N) REDUCTION(+:NRET) SCHEDULE(STATIC)
   DO N=1,NPTS
     IF(XPTS(N).GE.XMIN.AND.XPTS(N).LE.XMAX.AND. &
        YPTS(N).GE.YMIN.AND.YPTS(N).LE.YMAX) THEN
       RLON(N)=MOD(RLON1+DLON*(XPTS(N)-1)+3600,360.)
       RLAT(N)=2*ATAN(EXP(DPHI*(YPTS(N)-YE)))*DPR-90
       NRET=NRET+1
       IF(LROT)  CALL MERCATOR_VECT_ROT(CROT(N),SROT(N))
       IF(LMAP)  CALL MERCATOR_MAP_JACOB(RLAT(N),XLON(N),XLAT(N),YLON(N),YLAT(N))
       IF(LAREA) CALL MERCATOR_GRID_AREA(RLAT(N),AREA(N))
     ELSE
       RLON(N)=FILL
       RLAT(N)=FILL
     ENDIF
   ENDDO
!$OMP END PARALLEL DO
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  TRANSLATE EARTH COORDINATES TO GRID COORDINATES
 ELSEIF(IOPT.EQ.-1) THEN
!$OMP PARALLEL DO PRIVATE(N) REDUCTION(+:NRET) SCHEDULE(STATIC)
   DO N=1,NPTS
     IF(ABS(RLON(N)).LE.360.AND.ABS(RLAT(N)).LT.90) THEN
       XPTS(N)=1+HI*MOD(HI*(RLON(N)-RLON1)+3600,360.)/DLON
       YPTS(N)=YE+LOG(TAN((RLAT(N)+90)/2/DPR))/DPHI
       IF(XPTS(N).GE.XMIN.AND.XPTS(N).LE.XMAX.AND. &
          YPTS(N).GE.YMIN.AND.YPTS(N).LE.YMAX) THEN
         NRET=NRET+1
         IF(LROT)  CALL MERCATOR_VECT_ROT(CROT(N),SROT(N))
         IF(LMAP)  CALL MERCATOR_MAP_JACOB(RLAT(N),XLON(N),XLAT(N),YLON(N),YLAT(N))
         IF(LAREA) CALL MERCATOR_GRID_AREA(RLAT(N),AREA(N))
       ELSE
         XPTS(N)=FILL
         YPTS(N)=FILL
       ENDIF
     ELSE
       XPTS(N)=FILL
       YPTS(N)=FILL
     ENDIF
   ENDDO
!$OMP END PARALLEL DO
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE GDSWZD_MERCATOR
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 SUBROUTINE MERCATOR_ERROR(IOPT,FILL,RLAT,RLON,XPTS,YPTS,NPTS)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  MERCATOR_ERROR   ERROR HANDLER
!   PRGMMR: GAYNO       ORG: W/NMC23       DATE: 2015-07-13
!
! ABSTRACT: UPON AN ERROR, THIS SUBPROGRAM ASSIGNS
!           A "FILL" VALUE TO THE OUTPUT FIELDS.

! PROGRAM HISTORY LOG:
! 2015-07-13  GAYNO     INITIAL VERSION
!
! USAGE:    CALL MERCATOR_ERROR(IOPT,FILL,RLAT,RLON,XPTS,YPTS,NPTS)
!
!   INPUT ARGUMENT LIST:
!     IOPT     - INTEGER OPTION FLAG
!                (+1 TO COMPUTE EARTH COORDS OF SELECTED GRID COORDS)
!                (-1 TO COMPUTE GRID COORDS OF SELECTED EARTH COORDS)
!     NPTS     - INTEGER MAXIMUM NUMBER OF COORDINATES
!     FILL     - REAL FILL VALUE TO SET INVALID OUTPUT DATA
!                (MUST BE IMPOSSIBLE VALUE; SUGGESTED VALUE: -9999.)
!   OUTPUT ARGUMENT LIST:
!     RLON     - REAL (NPTS) EARTH LONGITUDES IF IOPT<0
!     RLAT     - REAL (NPTS) EARTH LATITUDES IF IOPT<0
!     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT>0
!     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT>0
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER, INTENT(IN   ) :: IOPT, NPTS
!
 REAL,    INTENT(IN   ) :: FILL
 REAL,    INTENT(  OUT) :: RLAT(NPTS),RLON(NPTS)
 REAL,    INTENT(  OUT) :: XPTS(NPTS),YPTS(NPTS)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 IF(IOPT>=0) THEN
   RLON=FILL
   RLAT=FILL
 ENDIF
 IF(IOPT<=0) THEN
   XPTS=FILL
   YPTS=FILL
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE MERCATOR_ERROR
!
 SUBROUTINE MERCATOR_VECT_ROT(CROT,SROT)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  MERCATOR_VECT_ROT   VECTOR ROTATION FIELDS FOR
!                                  MERCATOR CYLINDRICAL GRIDS
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE VECTOR ROTATION SINES AND
!           COSINES FOR A MERCATOR CYLINDRICAL GRID.
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
! 2015-09-17  GAYNO    RENAME AS "MERCATOR_VECT_ROT".
!
! USAGE:    CALL MERCATOR_VECT_ROT(CROT,SROT)
!
!   INPUT ARGUMENT LIST:
!     NONE
!
!   OUTPUT ARGUMENT LIST:
!     CROT     - CLOCKWISE VECTOR ROTATION COSINES (REAL)
!     SROT     - CLOCKWISE VECTOR ROTATION SINES (REAL)
!                (UGRID=CROT*UEARTH-SROT*VEARTH;
!                 VGRID=SROT*UEARTH+CROT*VEARTH)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 IMPLICIT NONE

 REAL,                INTENT(  OUT) :: CROT, SROT

 CROT=1.0
 SROT=0.0

 END SUBROUTINE MERCATOR_VECT_ROT
!
 SUBROUTINE MERCATOR_MAP_JACOB(RLAT,XLON,XLAT,YLON,YLAT)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  MERCATOR_MAP_JACOB  MAP JACOBIANS FOR
!                                  MERCATOR CYLINDRICAL GRIDS
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE MAP JACOBIANS FOR
!           A MERCATOR CYLINDRICAL GRID.
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
! 2015-09-17  GAYNO    RENAME AS "MERCATOR_MAP_JACOB"
!
! USAGE:  CALL MERCATOR_MAP_JACOB(RLAT,XLON,XLAT,YLON,YLAT)
!
!   INPUT ARGUMENT LIST:
!     RLAT     - LATITUDE IN DEGREES (REAL)
!
!   OUTPUT ARGUMENT LIST:
!     XLON     - DX/DLON IN 1/DEGREES (REAL)
!     XLAT     - DX/DLAT IN 1/DEGREES (REAL)
!     YLON     - DY/DLON IN 1/DEGREES (REAL)
!     YLAT     - DY/DLAT IN 1/DEGREES (REAL)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$

 IMPLICIT NONE

 REAL,                INTENT(IN   ) :: RLAT
 REAL,                INTENT(  OUT) :: XLON, XLAT, YLON, YLAT

 XLON=1./DLON
 XLAT=0.
 YLON=0.
 YLAT=1./DPHI/COS(RLAT/DPR)/DPR

 END SUBROUTINE MERCATOR_MAP_JACOB
!
 SUBROUTINE MERCATOR_GRID_AREA(RLAT,AREA)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  MERCATOR_GRID_AREA  GRID BOX AREA FOR
!                                  MERCATOR CYLINDRICAL GRIDS
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE GRID BOX AREA FOR
!           A MERCATOR CYLINDRICAL GRID.
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
! 2015-09-17  GAYNO    RENAME AS "MERCATOR_GRID_AREA"
!
! USAGE:  CALL MERCATOR_GRID_AREA(RLAT,AREA)
!
!   INPUT ARGUMENT LIST:
!     RLAT     - LATITUDE OF GRID POINT IN DEGREES (REAL)
!
!   OUTPUT ARGUMENT LIST:
!     AREA     - AREA WEIGHTS IN M**2 (REAL)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$

 IMPLICIT NONE

 REAL,              INTENT(IN   ) :: RLAT
 REAL,              INTENT(  OUT) :: AREA

 AREA=RERTH**2*COS(RLAT/DPR)**2*DPHI*DLON/DPR

 END SUBROUTINE MERCATOR_GRID_AREA

 END MODULE GDSWZD_MERCATOR_MOD


function MakeMagGridPoint(cilm, lmax, a, r, lat, lon, dealloc)
!------------------------------------------------------------------------------
!
!   This function will determine the 3 components (r-hat, theta-hat, phi-hat)
!   of the magnetic field vector at a given latitude, longitude and radius.
!   Latitude and longitude must be input in degrees. The input coefficients
!   must be Schmidt semi-normalized, excluding the Condon-Shortley phase
!   factor.
!
!   Calling Parameters
!
!       IN
!           cilm        Spherical harmonic coefficients, with dimensions
!                       (2, lmax+1, lmax+1).
!           lmax        Maximum degree used in the expansion.
!           a          Reference radius of the potential coefficients.
!           r           Radius where the magnetic field is computed (meters).
!           lat         Latitude where the gravity vector is computed, in
!                       degrees.
!           lon         Longitude where the gravity vector is computed, in
!                       degrees.
!
!       OPTIONAL (IN)
!           dealloc     If (1) deallocate saved memory in the Legendre function
!                       routines. Default (0) is not to deallocate memory.
!
!   Copyright (c) 2005-2020, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use SHTOOLS, only: PlmSchmidt_d1
    use ftypes

    implicit none

    real(dp), dimension(3) :: MakeMagGridPoint
    real(dp), intent(in) :: cilm(:,:,:), a, r, lat, lon
    integer(int32), intent(in) :: lmax
    integer(int32), intent(in), optional :: dealloc
    real(dp) :: pi, x, expand(3), lon_rad, prefactor(lmax)
    integer(int32) :: index, l, m, l1, m1, lmax_comp, astat(4)
    real(dp), allocatable :: pl(:), dpl(:), cosm(:), sinm(:)

    if (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < lmax+1 .or. &
            size(cilm(1,1,:)) < lmax+1) then
        print*, "Error --- MakeMagGridPoint"
        print*, "CILM must be dimensioned as (2, LMAX+1, LMAX+1) " // &
                "where LMAX is ", lmax
        print*, "Input dimension is ", size(cilm(:,1,1)), size(cilm(1,:,1)), &
                size(cilm(1,1,:))
        stop
    end if

    lmax_comp = min(lmax, size(cilm(1,1,:)) - 1)

    allocate (pl(((lmax_comp+1) * (lmax_comp+2)) / 2), stat = astat(1))
    allocate (dpl(((lmax_comp+1) * (lmax_comp+2)) / 2), stat = astat(2))
    allocate (cosm(lmax_comp+1), stat = astat(3))
    allocate (sinm(lmax_comp+1), stat = astat(4))

    if (sum(astat(1:4)) /= 0) then
        print*, "Error --- MakeMagGridPoint"
        print*, "Cannot allocate memory for arrays PL, DPL, COSM and SINM", &
                astat(1), astat(2), astat(3), astat(4)
        stop
    end if

    pi = acos(-1.0_dp)
    x = sin(lat * pi / 180.0_dp)
    lon_rad = lon * pi / 180.0_dp

    call PlmSchmidt_d1(pl, dpl, lmax_comp, x, csphase = 1)
    dpl = -dpl * cos(lat * pi / 180.0_dp)

    ! Precompute sines and cosines. Use multiple angle identity to minimize
    ! number of calls to SIN and COS.
    sinm(1) = 0.0_dp
    cosm(1) = 1.0_dp

    if (lmax_comp > 0) then
        sinm(2) = sin(lon_rad)
        cosm(2) = cos(lon_rad)
    end if

    do m = 2, lmax_comp, 1
        m1 = m + 1
        sinm(m1) = 2 * sinm(m) * cosm(2) - sinm(m-1)
        cosm(m1) = 2 * cosm(m) * cosm(2) - cosm(m-1)
    end do

    prefactor(1) = a / r  ! l=1
    do l = 2, lmax_comp, 1
        prefactor(l) = prefactor(l-1) * (a / r)
    end do

    expand(1) = -cilm(1,1,1)
    expand(2:3) = 0.0_dp

    do l = 1, lmax_comp, 1
        l1 = l + 1
        index = (l+1) * l / 2 + 1
        expand(1) = expand(1) - prefactor(l) * l1 * cilm(1,l1,1) * pl(index)
        expand(2) = expand(2) + prefactor(l) * cilm(1,l1,1) * dpl(index)

        do m = 1, l, 1
            m1 = m + 1
            index = index + 1
            expand(1) = expand(1) - prefactor(l) * l1 * pl(index) * &
                        (cilm(1,l1,m1) * cosm(m1) + cilm(2,l1,m1) * sinm(m1))
            expand(2) = expand(2) + prefactor(l) * dpl(index) * &
                        (cilm(1,l1,m1) * cosm(m1) + cilm(2,l1,m1) * sinm(m1))
            expand(3) = expand(3) + prefactor(l) * pl(index) * &
                        (-m * cilm(1,l1,m1) * sinm(m1) &
                         + m * cilm(2,l1,m1) * cosm(m1))
        end do

    end do

    expand(1:3) = -expand(1:3) * (a / r)**2
    if (abs(lat) /= 90.0_dp) then
        expand(3) = expand(3) / cos(lat * pi / 180.0_dp)
    else
        expand(3) = 0.0_dp
    end if

    MakeMagGridPoint(1:3) = expand(1:3)

    ! deallocate memory
    if (present(dealloc)) then
        if (dealloc == 1) then
            call PlmSchmidt_d1(pl, dpl, -1, x)
        end if
    end if

    deallocate (pl)
    deallocate (dpl)
    deallocate (cosm)
    deallocate (sinm)

end function MakeMagGridPoint


      subroutine qlkfn(cx,ieps,xpi,xm,xmp)
*************************************************************************
*									*
*       RKE & GZ: adapted from ffzkfn routine (19/02/2008)
*	Calculate the K-function given in Eq. 2.7 of                    *
*	%\cite{Beenakker:1988jr}                                        *
*       \bibitem{Beenakker:1988jr}                                      *
*        W.~Beenakker and A.~Denner,                                    *
*  %``INFRARED DIVERGENT SCALAR BOX INTEGRALS WITH APPLICATIONS IN THE  *
*  %ELECTROWEAK STANDARD MODEL,''                                       *
*       Nucl.\ Phys.\  B {\bf 338}, 349 (1990).                         *
*       %%CITATION = NUPHA,B338,349;%%	                        	*
*									*
*			      1-sqrt(1-4*m*mp/(z-(m-mp)^2))		*
*		K(p^2,m,mp) = -----------------------------		*
*			      1+sqrt(1-4*m*mp/(z-(m-mp)^2))		*
*									*
*	and fill x(1) = -K, x(2) = 1+K, x(3) = 1-K			*
*	the roots are allowed to be imaginary				*
*	ieps gives the sign of the imaginary part of -K: 1 -> +i*eps    *
*									*
*************************************************************************
      implicit none
      include 'qlconstants.f'
      LOGICAL qlzero
      DOUBLE PRECISION xpi,xm,xmp,xx1,ieps
      DOUBLE COMPLEX root,invopr,cx(3),rat

      if  ((xm .eq. 0d0) .or. (xmp .eq. 0d0)) then
      write(6,*) 'Error in qlkfn,xm,xmp=',xm,xmp
      stop
      endif

      xx1 = xpi - (xm-xmp)**2
      rat=dcmplx(xx1/(4d0*xm*xmp))

      if (qlzero(dble(rat))) then
	   cx(2) = -2d0*im*sqrt(rat)+2d0*rat
	   cx(1) = cone-cx(2)
	   cx(3) = ctwo-cx(2)
      else

           root = sqrt((rat-cone)/rat)
	   invopr = cone/(cone+root)
           cx(1) = -invopr**2/rat
           cx(2) = ctwo*invopr
           cx(3) = ctwo*root*invopr
       endif
       ieps = 1d0
       return
       end


SUBROUTINE posdin()

	USE velpre
	USE parametros
	USE mms_m
	USE ls_param
	IMPLICIT NONE
	integer :: i, j, k
	real(8) :: aux1, aux2
	real(8), dimension(nx1,ny,nz) :: rhox, hs_x
	real(8), dimension(nx,ny1,nz) :: rhoy, hs_y
	real(8), dimension(nx,ny,nz1) :: rhoz, hs_z

!===============================================================================================================
!PARTE 5	!%%%!-- Correção das Velocidades e do Desnível --!%%%!

	! velocidades corrigidas
	aux1 = dt / dx
	aux2 = dt / dy

	call interpx_cf(rho,nx,ny,nz,rhox) !(nx1,ny,nz)
	call interpy_cf(rho,nx,ny,nz,rhoy) !(nx,ny1,nz)
	call interpz_cf(rho,nx,ny,nz,rhoz) !(nx,ny,nz1)

	do k = 1, nz
	do j = 1, ny
	do i = 1, nx1
		u(i,j,k) = u(i,j,k) -aux1 * ( prd1(i,j,k)-prd1(i-1,j,k) ) / rhox(i,j,k)! + dt*tf_px(i,j,k)/rhox(i,j,k)
	enddo
	enddo

	do j = 1, ny1
	do i = 1, nx
		v(i,j,k) = v(i,j,k) -aux2 * ( prd1(i,j,k)-prd1(i,j-1,k) ) / rhoy(i,j,k)! + dt*tf_py(i,j,k)/rhoy(i,j,k)
	enddo
	enddo
	enddo

	do k = 1, nz1
	do j = 1, ny
	do i = 1, nx
		w(i,j,k) = w(i,j,k) - dt / dz * ( prd1(i,j,k)-prd1(i,j,k-1) ) / rhoz(i,j,k)! + dt*tf_pz(i,j,k)/rhoz(i,j,k)

	enddo
	enddo
	enddo

!	w(:,:,1) = 0. !velocidade vertical no fundo é zero
!	do k = 1, nz
!	do j = 1, ny
!	do i = 1, nx
!		w(i,j,k+1) = w(i,j,k)-(u(i+1,j,k)-u(i,j,k))*dz/dx - (v(i,j+1,k)-v(i,j,k))*dz/dy
!	enddo
!	enddo
!	enddo

!	call interpx_cf(hs,nx,ny,nz,hs_x) !(nx1,ny,nz)
!	call interpy_cf(hs,nx,ny,nz,hs_y) !(nx,ny1,nz)
!	call interpz_cf(hs,nx,ny,nz,hs_z) !(nx,ny,nz1)

!	do k = 1, nz
!	do j = 1, ny
!	do i = 1, nx1
!	 if (hs_x(i,j,k) < 0.0001) then
!	  u(i,j,k) = 0.
!	 endif
!	enddo
!	enddo
!	enddo

!	do k = 1, nz
!	do j = 1, ny1
!	do i = 1, nx
!	 if (hs_y(i,j,k) < 0.0001) then
!	  v(i,j,k) = 0.
!	 endif
!	enddo
!	enddo
!	enddo

!	do k = 1, nz1
!	do j = 1, ny
!	do i = 1, nx
!	 if (hs_z(i,j,k) < 0.0001) then
!	  w(i,j,k) = 0.
!	 endif
!	enddo
!	enddo
!	enddo

	prd = prd1
	!prd1 = prd1 + prd0 !arrumar erro da pressão quando prd0 =/ 0

END SUBROUTINE posdin


MODULE xc_pw92_gth_module

  implicit none

  PRIVATE
  PUBLIC :: calc_pw92_gth

  real(8),parameter :: a0=0.4581652932831429d0 ,da0=0.119086804055547d0
  real(8),parameter :: a1=2.217058676663745d0  ,da1=0.6157402568883345d0
  real(8),parameter :: a2=0.7405551735357053d0 ,da2=0.1574201515892867d0
  real(8),parameter :: a3=0.01968227878617998d0,da3=0.003532336663397157d0
  real(8),parameter :: b1=1.0d0                ,db1=0.0d0
  real(8),parameter :: b2=4.504130959426697d0  ,db2=0.2673612973836267d0
  real(8),parameter :: b3=1.110667363742916d0  ,db3=0.2052004607777787d0
  real(8),parameter :: b4=0.02359291751427506d0,db4=0.004200005045691381d0

  include 'mpif.h'

CONTAINS

  SUBROUTINE calc_pw92_gth(n1,n2,nspin,s1,s2,rho,Exc,Vxc,dV,comm_grid)

    integer,intent(IN)  :: n1,n2,nspin,s1,s2,comm_grid
    real(8),intent(IN)  :: rho(n1:n2,nspin),dV
    real(8),intent(OUT) :: Exc,Vxc(n1:n2,s1:s2)
    real(8) :: trho,zeta,d0,d1,d2,d3,d4,d5,fx,rs,epsilon_xc
    real(8) :: a0z,a1z,a2z,a3z,b1z,b2z,b3z,b4z,factor(2)
    real(8) :: de_dr,dr_dn,de_df,df_dz
    integer :: i,ierr

    Exc = 0.d0
    Vxc = 0.d0

    d0 = 0.5d0*nspin
    d1 = 4.d0/3.d0
    d2 = 1.d0/( 2.d0*(2.d0**(1.d0/3.d0)-1.d0) )
    d3 = 3.d0/(4.d0*acos(-1.d0))
    d4 = 1.d0/3.d0
    d5 = 1.d0/(4.d0*acos(-1.d0))

    factor(1) = 2.d0
    factor(2) =-2.d0

    do i=n1,n2

       trho = d0*( rho(i,1)+rho(i,nspin) )

       if ( trho <= 0.d0 ) cycle

       zeta = ( rho(i,1)-rho(i,nspin) )/trho

       fx = ( abs(1.d0+zeta)**d1 + abs(1.d0-zeta)**d1 - 2.d0 )*d2

       rs = (d3/trho)**d4

       a0z = a0 + da0*fx
       a1z = a1 + da1*fx
       a2z = a2 + da2*fx
       a3z = a3 + da3*fx

       b1z = b1 + db1*fx
       b2z = b2 + db2*fx
       b3z = b3 + db3*fx
       b4z = b4 + db4*fx

       epsilon_xc = -( a0z + a1z*rs + a2z*rs**2 + a3z*rs**3 ) &
                    /( b1z*rs + b2z*rs**2 + b3z*rs**3 + b4z*rs**4 )

       Exc = Exc + trho*epsilon_xc

       de_df = ( -( da0 + da1*rs + da2*rs**2 + da3*rs**3 ) &
                 *( b1z*rs + b2z*rs**2 + b3z*rs**3 + b4z*rs**4 ) &
                 +( a0z + a1z*rs + a2z*rs**2 + a3z*rs**3 ) &
                 *( db1*rs + db2*rs**2 + db3*rs**3 + db4*rs**4 ) &
               )/( b1z*rs + b2z*rs**2 + b3z*rs**3 + b4z*rs**4 )**2

       df_dz = d1*d2*( abs(1.d0+zeta)**d4 - abs(1.d0-zeta)**d4 )

       de_dr = ( -( a1z + 2*a2z*rs + 3*a3z*rs**2 )*( b1z*rs + b2z*rs**2 + b3z*rs**3 + b4z*rs**4 ) &
                 +( a0z + a1z*rs + a2z*rs**2 + a3z*rs**3 ) &
                 *( b1z + 2*b2z*rs + 3*b3z*rs**2 + 4*b4z*rs**3 ) &
               )/( b1z*rs + b2z*rs**2 + b3z*rs**3 + b4z*rs**4 )**2

       dr_dn = -d5/(trho*rs)**2

       Vxc(i,s1) = epsilon_xc + trho*( de_dr*dr_dn + de_df*df_dz*factor(s1)*rho(i,s2)/trho**2 )
       Vxc(i,s2) = epsilon_xc + trho*( de_dr*dr_dn + de_df*df_dz*factor(s2)*rho(i,s1)/trho**2 )

    end do

    d0=Exc*dV
    call mpi_allreduce(d0,Exc,1,MPI_REAL8,MPI_SUM,comm_grid,ierr)

  END SUBROUTINE calc_pw92_gth

END MODULE xc_pw92_gth_module


! This performs the calculations necessary to run a simulation using a
! Silvera-Goldman (SG) potential for para-hydrogen. See I. Silvera and V.
! Goldman, J. Chem. Phys., 69, 4209 (1978).
!
! Copyright (C) 2013, Joshua More and Michele Ceriotti
!
! Permission is hereby granted, free of charge, to any person obtaining
! a copy of this software and associated documentation files (the
! "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish,
! distribute, sublicense, and/or sell copies of the Software, and to
! permit persons to whom the Software is furnished to do so, subject to
! the following conditions:
!
! The above copyright notice and this permission notice shall be included
! in all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
! EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
! MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
! IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
! CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
! TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
! SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
!
!
! This contains the functions that calculate the potential, forces and
! virial tensor of liquid para-hydrogen
! Includes functions which calculate the long-range correction terms for a
! simulation with a sharp nearest-neighbour cut-off.
!
! Functions:
!    f_c: Calculates the damping function for the dispersive interactions
!       at short range.
!    exp_func: Calculates the short range repulsive part of the SG potential.
!    SG_functions: Calculates the SG pair potential and the magnitude of the
!       forces acting on a pair of atoms.
!    SG_fij: Calculates the SG pair potential and force vector for the
!       interaction of a pair of atoms.
!    SG_longrange: Calculates the long range correction to the potential
!       and virial.
!    SG_getall: Calculates the potential and virial of the system and the
!       forces acting on all the atoms.

      MODULE SG
         USE DISTANCE
      IMPLICIT NONE

      ! Parameters of the SG potential. This potential is of the form:
      ! V(r) = exp(alpha - beta*r - delta*r**2) -
      !        (C_6/r**6 + C_8/r**8 - C_9/r**9 + C_10/r**10)*f_c(r)
      ! where f_c(r) = exp(-(rc_exp/r - 1)**2) if r <= rc_exp
      !            = 1 otherwise
      DOUBLE PRECISION, PARAMETER :: tau = 6.2831853071795862d0 !If you don't know why I used this name, you're not a real nerd
      DOUBLE PRECISION, PARAMETER :: alpha = 1.713d0
      DOUBLE PRECISION, PARAMETER :: beta = 1.5671d0
      DOUBLE PRECISION, PARAMETER :: delta = 0.00993d0
      DOUBLE PRECISION, PARAMETER :: delta_diff = delta*2.0d0
      DOUBLE PRECISION, PARAMETER :: rc_exp = 8.32d0
      DOUBLE PRECISION, PARAMETER :: C_6 = 12.14d0
      DOUBLE PRECISION, PARAMETER :: C_8 = 215.2d0
      DOUBLE PRECISION, PARAMETER :: C_9 = 143.1d0
      DOUBLE PRECISION, PARAMETER :: C_10 = 4813.9d0
      DOUBLE PRECISION, PARAMETER :: C_6_diff = C_6*6d0
      DOUBLE PRECISION, PARAMETER :: C_8_diff = C_8*8d0
      DOUBLE PRECISION, PARAMETER :: C_9_diff = C_9*9d0
      DOUBLE PRECISION, PARAMETER :: C_10_diff = C_10*10d0
      DOUBLE PRECISION, PARAMETER :: C_6_int = C_6/3d0
      DOUBLE PRECISION, PARAMETER :: C_8_int = C_8/5d0
      DOUBLE PRECISION, PARAMETER :: C_9_int = C_9/6d0
      DOUBLE PRECISION, PARAMETER :: C_10_int = C_10/7d0

      CONTAINS

         SUBROUTINE f_c(r, long_range, long_range_diff)
            ! Calculates the damping function for the dispersive interactions
            ! at short range.
            !
            ! Args:
            !    r: The separation of the atoms.
            !    long_range: The value of the damping function.
            !    long_range_diff: The differential of the damping function
            !       with respect to r.

            DOUBLE PRECISION, INTENT(IN) :: r
            DOUBLE PRECISION, INTENT(OUT) :: long_range
            DOUBLE PRECISION, INTENT(OUT) :: long_range_diff

            DOUBLE PRECISION dist_frac

            IF (r > rc_exp) THEN
               long_range = 1.0d0
               long_range_diff = 0.0d0
            ELSE
               dist_frac = rc_exp/r - 1.0d0
               long_range = dexp(-(dist_frac)**2)
               long_range_diff = 2.0d0*dist_frac*rc_exp*long_range/(r*r)
            END IF

         END SUBROUTINE

         SUBROUTINE exp_func(r, pot, force)
            ! Calculates the repulsive part of the SG force and potential
            ! between a pair of atoms at a given distance from each other.
            !
            ! Args:
            !    r: The separation of the atoms.
            !    pot: The repulsive part of the potential energy.
            !    force: The magnitude of the repulsive part of the force.

            DOUBLE PRECISION, INTENT(IN) :: r
            DOUBLE PRECISION, INTENT(OUT) :: pot
            DOUBLE PRECISION, INTENT(OUT) :: force

            pot = dexp(alpha - r*(beta + delta*r))
            force = (beta + delta_diff*r)*pot

         END SUBROUTINE

         SUBROUTINE SG_functions(r, pot, force)
            ! Calculates the magnitude of the SG force and potential between
            ! a pair of atoms at a given distance from each other.
            !
            ! Args:
            !    r: The separation of the atoms.
            !    pot: The SG interaction potential.
            !    force: The magnitude of the SG force.

            DOUBLE PRECISION, INTENT(IN) :: r
            DOUBLE PRECISION, INTENT(OUT) :: pot
            DOUBLE PRECISION, INTENT(OUT) :: force

            DOUBLE PRECISION long_range, long_range_diff, disp, disp_diff, exp_pot, exp_force
            DOUBLE PRECISION onr3, onr6, onr9, onr10

            onr3 = 1/(r*r*r)
            onr6 = onr3*onr3
            onr9 = onr6*onr3
            onr10 = onr9/r

            CALL exp_func(r, exp_pot, exp_force)
            CALL f_c(r, long_range, long_range_diff)

            disp = -(C_6*onr6 + C_8*onr9*r - C_9*onr9 + C_10*onr10)
            disp_diff = (C_6_diff*onr6/r + C_8_diff*onr9 - C_9_diff*onr10 + C_10_diff*onr10/r)

            pot = exp_pot + disp*long_range
            force = exp_force - disp_diff*long_range - disp*long_range_diff

         END SUBROUTINE

         SUBROUTINE SG_fij(rij, r, pot, fij)
            ! This calculates the SG potential energy and the magnitude and
            ! direction of the force acting on a pair of atoms.
            !
            ! Args:
            !    rij: The vector joining the two atoms.
            !    r: The separation of the two atoms.
            !    pot: The SG interaction potential.
            !    fij: The SG force vector.

            DOUBLE PRECISION, DIMENSION(3), INTENT(IN) :: rij
            DOUBLE PRECISION, INTENT(IN) :: r
            DOUBLE PRECISION, INTENT(OUT) :: pot
            DOUBLE PRECISION, DIMENSION(3), INTENT(OUT) :: fij

            DOUBLE PRECISION f_tot

            CALL SG_functions(r, pot, f_tot)
            fij = f_tot*rij/r

         END SUBROUTINE

         SUBROUTINE SG_longrange(rc, natoms, volume, pot_lr, vir_lr)
            ! Calculates the long range correction to the total potential and
            ! virial pressure.
            !
            ! Uses the tail correction for a sharp cut-off, with no smoothing
            ! function, as derived in Martyna and Hughes, Journal of Chemical
            ! Physics, 110, 3275, (1999).
            !
            ! Note that we will assume that rc > rc_exp, and that
            ! exp(alpha - beta*rc - delta*rc**2) << 0, so we can neglect the
            ! contribution of the repulsive potential and the dispersion
            ! damping function in the long range correction terms.
            !
            ! Args:
            !    rc: The cut-off radius.
            !    natoms: The number of atoms in the system.
            !    volume: The volume of the system box.
            !    pot_lr: The tail correction to the SG interaction potential.
            !    vir_lr: The tail correction to the SG virial pressure.

            DOUBLE PRECISION, INTENT(IN) :: rc
            INTEGER, INTENT(IN) :: natoms
            DOUBLE PRECISION, INTENT(IN) :: volume
            DOUBLE PRECISION, INTENT(OUT) :: pot_lr
            DOUBLE PRECISION, INTENT(OUT) :: vir_lr

            DOUBLE PRECISION onr3, onr5, onr6, onr7, prefactor

            onr3 = 1/(rc*rc*rc)
            onr6 = onr3*onr3
            onr5 = onr6*rc
            onr7 = onr6/rc
            prefactor = tau*natoms*natoms/volume

            pot_lr = prefactor*(-C_6_int*onr3 - C_8_int*onr5 + C_9_int*onr6 - C_10_int*onr7)
            vir_lr = prefactor*(-C_6*onr3 - C_8*onr5 + C_9*onr6 - C_10*onr7)/3 + pot_lr

         END SUBROUTINE

         SUBROUTINE SG_getall(rc, natoms, atoms, cell_h, cell_ih, index_list, n_list, pot, forces, virial)
            ! Calculates the SG potential energy and virial and the forces
            ! acting on all the atoms.
            !
            ! Args:
            !    rc: The cut-off radius.
            !    natoms: The number of atoms in the system.
            !    atoms: A vector holding all the atom positions.
            !    cell_h: The simulation box cell vector matrix.
            !    cell_ih: The inverse of the simulation box cell vector matrix.
            !    index_list: A array giving the last index of n_list that
            !       gives the neighbours of a given atom.
            !    n_list: An array giving the indices of the atoms that neighbour
            !       the atom determined by index_list.
            !    pot: The total potential energy of the system.
            !    forces: An array giving the forces acting on all the atoms.
            !    virial: The virial tensor, not divided by the volume.

            DOUBLE PRECISION, INTENT(IN) :: rc
            INTEGER, INTENT(IN) :: natoms
            DOUBLE PRECISION, DIMENSION(natoms,3), INTENT(IN) :: atoms
            DOUBLE PRECISION, DIMENSION(3,3), INTENT(IN) :: cell_h
            DOUBLE PRECISION, DIMENSION(3,3), INTENT(IN) :: cell_ih
            INTEGER, DIMENSION(natoms), INTENT(IN) :: index_list
            INTEGER, DIMENSION(natoms*(natoms-1)/2), INTENT(IN) :: n_list
            DOUBLE PRECISION, INTENT(OUT) :: pot
            DOUBLE PRECISION, DIMENSION(natoms,3), INTENT(OUT) :: forces
            DOUBLE PRECISION, DIMENSION(3,3), INTENT(OUT) :: virial

            INTEGER i, j, k, l, start
            DOUBLE PRECISION, DIMENSION(3) :: fij, rij
            DOUBLE PRECISION r2, pot_ij, pot_lr, vir_lr, volume

            forces = 0.0d0
            pot = 0.0d0
            virial = 0.0d0

            start = 1

            DO i = 1, natoms - 1
               ! Only loops over the neigbour list, not all the atoms.
               DO j = start, index_list(i)
                  CALL vector_separation(cell_h, cell_ih, atoms(i,:), atoms(n_list(j),:), rij, r2)
                  IF (r2 < rc*rc) THEN ! Only calculates contributions between neighbouring particles.
                     CALL SG_fij(rij, sqrt(r2), pot_ij, fij)

                     forces(i,:) = forces(i,:) + fij
                     forces(n_list(j),:) = forces(n_list(j),:) - fij
                     pot = pot + pot_ij
                     DO k = 1, 3
                        DO l = k, 3
                           ! Only the upper triangular elements calculated.
                           virial(k,l) = virial(k,l) + fij(k)*rij(l)
                        ENDDO
                     ENDDO
                  ENDIF
               ENDDO
               start = index_list(i) + 1
            ENDDO

            ! Assuming an upper-triangular vector matrix for the simulation box.
            volume = cell_h(1,1)*cell_h(2,2)*cell_h(3,3)
            CALL SG_longrange(rc, natoms, volume, pot_lr, vir_lr)
            pot = pot + pot_lr
            DO k = 1, 3
               virial(k,k) = virial(k,k) + vir_lr
            ENDDO

         END SUBROUTINE

      END MODULE


! AeroBulk / 2016 / L. Brodeau (brodeau@gmail.com)
! https://sourceforge.net/p/aerobulk
!
!   When using AeroBulk to produce scientific work, please acknowledge with the following citation:
!
!   Brodeau, L., B. Barnier, S. Gulev, and C. Woods, 2016: Climatologically
!   significant effects of some approximations in the bulk parameterizations of
!   turbulent air-sea fluxes. J. Phys. Oceanogr., doi:10.1175/JPO-D-16-0169.1.
!
!
MODULE mod_thermo

   USE mod_const

   IMPLICIT none

   PRIVATE

   PUBLIC :: visc_air, Lvap, e_sat, e_sat_buck, e_air, cp_air, rh_air, &
      &      rho_air, rho_air_adv, q_sat, q_air_rh, q_air_dp, q_sat_simple, &
      &      One_on_L_MO, gamma_moist

   REAL(wp), PARAMETER  :: &
      &      repsilon = 1.e-6

CONTAINS

   FUNCTION visc_air(Ta)

      !! Air viscosity (m^2/s) given from temperature in degrees...

      REAL(wp), DIMENSION(jpi,jpj) :: visc_air
      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: Ta  ! air temperature in (K)

      REAL(wp), DIMENSION(:,:), ALLOCATABLE :: TC, TC2

      ALLOCATE ( TC(jpi,jpj), TC2(jpi,jpj) )

      TC  = Ta - rt0   ! air temp, in deg. C
      TC2 = TC*TC

      visc_air = 1.326E-5*(1. + 6.542E-3*TC + 8.301E-6*TC2 - 4.84E-9*TC2*TC)

      DEALLOCATE ( TC, TC2 )

   END FUNCTION visc_air

   FUNCTION Lvap(zsst)

      !: latent heat of vaporization of water from temperature in (K)

      REAL(wp), DIMENSION(jpi,jpj)             :: Lvap   !: [J/kg]
      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: zsst   !: water temperature [K]

      Lvap = (2.501 - 0.00237*(zsst - rt0))*1.E6

   END FUNCTION Lvap

   FUNCTION e_sat(rT)

      !!**************************************************
      !! rT:     air temperature [K]
      !! e_sat:  water vapor at saturation [Pa]
      !!
      !! Recommended by WMO
      !!
      !! Goff, J. A., 1957: Saturation pressure of water on the new kelvin
      !! temperature scale. Transactions of the American society of heating
      !! and ventilating engineers, 347–354.
      !!
      !!**************************************************

      REAL(wp), DIMENSION(jpi,jpj)             :: e_sat !: vapour pressure at saturation  [Pa]
      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: rT    !: temperature (K)

      REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztmp

      ALLOCATE ( ztmp(jpi,jpj) )

      ztmp(:,:) = rtt0/rT(:,:)

      e_sat = 100.*( 10.**(10.79574*(1. - ztmp) - 5.028*LOG10(rT/rtt0)         &
         &       + 1.50475*10.**(-4)*(1. - 10.**(-8.2969*(rT/rtt0 - 1.)) )   &
         &       + 0.42873*10.**(-3)*(10.**(4.76955*(1. - ztmp)) - 1.) + 0.78614) )

      DEALLOCATE ( ztmp )

   END FUNCTION e_sat

   FUNCTION e_sat_buck(rT, slp)

      !!**************************************************
      !!  rT:     air temperature          [K]
      !! slp:     atmospheric pressure     [Pa]
      !! e_sat:  water vapor at saturation [Pa]
      !!
      !! Based on Buck' formula for saturation vapor pressure
      !! from Buck (1981), J. App. Meteor., 1527-1532.
      !!
      !! This version follows the saturation specific humidity computation in
      !! the COARE Fortran code v2.5b.  This results in an increase of ~5% in
      !! latent heat flux compared to the calculation with Teten's
      !!
      !!**************************************************

      REAL(wp), DIMENSION(jpi,jpj)             :: e_sat_buck !: vapour pressure at saturation [Pa]
      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: rT, &        !: temperature                   [K]
         &                                        slp          !: atmospheric pressure          [Pa]

      REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztmp

      ALLOCATE ( ztmp(jpi,jpj) )

      !! Achtung: originaly given with temperature in deg.C and pressure in
      !!          millibars! 1 mb = 100 Pa !!!

      ztmp(:,:) = rT(:,:) - rt0

      !! Buck 1981:
      !! Buck, A. L., New equations for computing vapor pressure and enhancement
      !! factor, J. Appl. Meteorol., 20, 1527-1532, 1981
      !e_sat_buck = 611.21 * EXP( 17.502*ztmp/(ztmp + 240.97) )

      !! Official COARE 3.0 code:
      e_sat_buck = 611.2*(1.0007 + 3.46e-8*slp) * EXP( 17.502*ztmp/(ztmp + 240.97) )

      !! Kara et al. 2000:
      !!e_sat_buck = 611.21*(1. + 3.46E-8*slp)*EXP( (17.5*ztmp)/(240.97 + ztmp) )

      DEALLOCATE ( ztmp )

   END FUNCTION e_sat_buck

   FUNCTION e_air(q_air, slp)

      !!--------------------------------------------------------------------
      !!                  **** Function e_air ****
      !!
      !! Gives vapour pressure of air from pressure and specific humidity
      !!
      !!--------------------------------------------------------------------

      REAL(wp), DIMENSION(jpi,jpj)             ::    e_air      !: vapour pressure at saturation  [Pa]
      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::          &
         &                 q_air,   &  ! specific humidity of air      [kg/kg]
         &                 slp        ! atmospheric pressure          [Pa]

      REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ee, e_old
      REAL :: diff

      ALLOCATE ( ee(jpi,jpj), e_old(jpi,jpj) )

      diff  = 1.
      e_old = q_air*slp/reps0

      DO WHILE ( diff > repsilon )
         ee = q_air/reps0*(slp - (1. - reps0)*e_old)
         diff  = SUM( abs( ee - e_old) )
         e_old = ee
      END DO

      e_air = ee

      DEALLOCATE ( ee, e_old )

   END FUNCTION e_air

   FUNCTION cp_air( pqa )
      !!-------------------------------------------------------------------------------
      !! ** Purpose : Compute specific heat (Cp) of MOIST air
      !!
      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
      !!-------------------------------------------------------------------------------
      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa     !: air spec. hum. [kg/kg]
      REAL(wp), DIMENSION(jpi,jpj)             :: cp_air  !: [J/K/kg]
      !!-------------------------------------------------------------------------------
      !
      cp_air = Cp_dry + Cp_vap*pqa
      !
   END FUNCTION cp_air

   FUNCTION rh_air(q_air, t_air, slp)

      !! Relative humidity of air

      REAL(wp), DIMENSION(jpi,jpj)             :: rh_air  !: relative humidity [] (fraction!!!, not percent!)
      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: &
         &                 q_air,   &     !: specific humidity of air      [kg/kg]
         &                 t_air,   &     !: air temperature               [K]
         &                 slp           !: atmospheric pressure          [Pa]

      rh_air = e_sat(t_air)
      rh_air = e_air(q_air,slp) / rh_air

   END FUNCTION rh_air

   FUNCTION q_air_rh(rha, ta, slp)

      !! Specific humidity of air from Relative humidity

      REAL(wp), DIMENSION(jpi,jpj) :: q_air_rh

      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: &
         &     rha,     &   !: relative humidity      [fraction, not %!!!]
         &     ta,      &   !: air temperature        [K]
         &     slp         !: atmospheric pressure          [Pa]

      REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztmp

      ALLOCATE ( ztmp(jpi,jpj) )

      ztmp       = rha*e_sat(ta)
      q_air_rh = ztmp*reps0/(slp - (1. - reps0)*ztmp)

      DEALLOCATE ( ztmp )

   END FUNCTION q_air_rh

   FUNCTION q_air_dp(da, slp)
      !!
      !! Air specific humidity from dew point temperature
      !!
      REAL(wp), DIMENSION(jpi,jpj) :: q_air_dp  !: kg/kg
      !!
      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: &
         &     da,     &    !: dew-point temperature   [K]
         &     slp         !: atmospheric pressure    [Pa]
      !!
      !q_air_dp = e_sat(da)*reps0/(slp - (1. - reps0)*e_sat(da))
      q_air_dp = e_sat(da)*reps0/(slp - (1. - reps0)*e_sat(da))
      !!
   END FUNCTION q_air_dp

   FUNCTION rho_air( ptak, pqa, pslp )
      !!-------------------------------------------------------------------------------
      !! ** Purpose : compute density of (moist) air with eq. of state
      !!
      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
      !!-------------------------------------------------------------------------------
      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak, &  !: air temperature   [K]
         &                                        pqa, &  !: air spec. hum.    [kg/kg]
         &                                        pslp    !: pressure in       [Pa]
      REAL(wp), DIMENSION(jpi,jpj)             ::   rho_air   !:              [kg/m^3]
      !!-------------------------------------------------------------------------------
      !
      rho_air = pslp/(R_dry*ptak*(1._wp + rctv0*pqa))
      !
   END FUNCTION rho_air

   FUNCTION rho_air_adv(zt, zq, zP)
      !!
      !! Advanced version, using TRUE virtual temperature
      !!
      REAL(wp), DIMENSION(jpi,jpj) :: rho_air_adv      !: density of air [kg/m^3]
      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::  &
         &      zt,       &     !: air temperature in (K)
         &      zq,       &     !: air spec. hum. (kg/kg)
         &      zP              !: pressure in       (Pa)
      !!
      REAL(wp), DIMENSION(jpi,jpj) :: ztv !: virtual temperature
      !!
      ztv = zt/(1. - e_air(zq, zP)/zP*(1. - reps0))
      !!
      rho_air_adv = zP/(R_dry*ztv)
      !!
   END FUNCTION rho_air_adv

   FUNCTION q_sat(temp, slp,  cform)

      !! Specific humidity at saturation

      REAL(wp), DIMENSION(jpi,jpj) :: q_sat
      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::  &
         &                  temp,  &   !: sea surface temperature         [K]
         &                  slp       !: sea level atmospheric pressure  [Pa]

      CHARACTER(len=*), OPTIONAL, INTENT(in) :: cform

      !! Local :
      LOGICAL :: lbuck  !: we use Buck formula to compute e_sat instead of Goff 1957
      REAL(wp), DIMENSION(jpi,jpj) ::  &
         &    e_s

      lbuck = .FALSE.
      IF ( PRESENT(cform) ) THEN
         IF ( (TRIM(cform) == 'buck').OR.(TRIM(cform) == 'Buck').OR.(TRIM(cform) == 'BUCK') ) THEN
            lbuck = .TRUE.
         END IF
      END IF

      !! Vapour pressure at saturation :
      IF ( lbuck ) THEN
         e_s = e_sat_buck(temp, slp)
      ELSE
         e_s = e_sat(temp)  ! using Goff !
      END IF

      q_sat = reps0*e_s/(slp - (1. - reps0)*e_s)

   END FUNCTION q_sat

   FUNCTION e_sat_ice(rt)

      REAL(wp), DIMENSION(jpi,jpj) :: e_sat_ice !: vapour pressure at saturation in presence of ice [Pa]
      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: rt

      REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ztmp

      ALLOCATE ( ztmp(jpi,jpj) )

      ztmp(:,:) = 273.16/rt(:,:)

      e_sat_ice = 100.*(10**( -9.09718*(ztmp - 1.) - 3.56654*LOG10(ztmp) &
         &                + 0.876793*(1. - rt/273.16) + LOG10(6.1071) ) )

      DEALLOCATE ( ztmp )

   END FUNCTION e_sat_ice

   FUNCTION q_sat_simple(temp, zrho)

      REAL(wp), DIMENSION(jpi,jpj)             :: q_sat_simple
      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: &
         &       temp,   &  !: sea surface temperature  [K]
         &       zrho       !: air density         [kg/m^3]

      q_sat_simple = 640380./zrho * exp(-5107.4/temp)

   END FUNCTION q_sat_simple

   FUNCTION One_on_L_MO(theta_a, q_a, us, ts, qs)

      !! ********************************************************************************
      !! Evaluates the 1./(Monin Obukhov length) from average temperature, specific humidity
      !! and frictional u, t and q
      !! 2015: L. Brodeau
      !! ********************************************************************************

      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: theta_a,  &  !: average potetntial air temperature [K]
         &                                q_a,      &  !: average specific humidity of air   [kg/kg]
         &                                us, ts, qs   !: frictional velocity, temperature and humidity

      REAL(wp), DIMENSION(jpi,jpj)             :: One_on_L_MO         !: 1./(Monin Obukhov length) [m^-1]

      REAL(wp), DIMENSION(:,:), ALLOCATABLE  :: rqa

      ALLOCATE ( rqa(jpi,jpj) )

      rqa = (1. + rctv0*q_a)

      One_on_L_MO =  grav*vkarmn*(ts*rqa + rctv0*theta_a*qs) / ( us*us * theta_a*rqa )

      DEALLOCATE ( rqa )

   END FUNCTION One_on_L_MO

   FUNCTION gamma_moist( ptak, pqa )
      !!----------------------------------------------------------------------------------
      !! ** Purpose : Compute the moist adiabatic lapse-rate.
      !!     => http://glossary.ametsoc.org/wiki/Moist-adiabatic_lapse_rate
      !!     => http://www.geog.ucsb.edu/~joel/g266_s10/lecture_notes/chapt03/oh10_3_01/oh10_3_01.html
      !!
      !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk)
      !!----------------------------------------------------------------------------------
      REAL(wp), DIMENSION(jpi,jpj)             :: gamma_moist
      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak, pqa ! air temperature (K) and specific humidity (kg/kg)
      !
      INTEGER  ::   ji, jj         ! dummy loop indices
      REAL(wp) :: zrv, ziRT        ! local scalar
      !!----------------------------------------------------------------------------------
      !
      DO jj = 1, jpj
         DO ji = 1, jpi
            zrv = pqa(ji,jj) / (1. - pqa(ji,jj))
            ziRT = 1./(R_dry*ptak(ji,jj))    ! 1/RT
            gamma_moist(ji,jj) = grav * ( 1. + L0vap*zrv*ziRT ) / ( Cp_dry + L0vap*L0vap*zrv*reps0*ziRT/ptak(ji,jj) )
         END DO
      END DO
      !
   END FUNCTION gamma_moist

END MODULE mod_thermo


!*==sblat1.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022

!> \brief \b SBLAT1
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       PROGRAM SBLAT1
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!>    Test program for the REAL Level 1 BLAS.
!>
!>    Based upon the original BLAS test routine together with:
!>    F06EAF Example Program Text
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date April 2012
!
!> \ingroup single_blas_testing
!
!  =====================================================================
      PROGRAM SBLAT1
      IMPLICIT NONE
!*--SBLAT142
!
!  -- Reference BLAS test routine (version 3.8.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     April 2012
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , N
      LOGICAL PASs
!     .. Local Scalars ..
      REAL sfac
      INTEGER ic
!     .. External Subroutines ..
      EXTERNAL CHECK0 , CHECK1 , CHECK2 , CHECK3 , HEADER
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , PASs
!     .. Data statements ..
      DATA sfac/9.765625E-4/
!     .. Executable Statements ..
      WRITE (NOUT,99001)
!
99001 FORMAT (' Real BLAS Test Program Results',/1X)
      DO ic = 1 , 13
         ICAse = ic
         CALL HEADER
!
!        .. Initialize  PASS,  INCX,  and INCY for a new case. ..
!        .. the value 9999 for INCX or INCY will appear in the ..
!        .. detailed  output, if any, for cases  that do not involve ..
!        .. these parameters ..
!
         PASs = .TRUE.
         INCx = 9999
         INCy = 9999
         IF ( ICAse==3 .OR. ICAse==11 ) THEN
            CALL CHECK0(sfac)
         ELSEIF ( ICAse==7 .OR. ICAse==8 .OR. ICAse==9 .OR. ICAse==10 ) &
     &            THEN
            CALL CHECK1(sfac)
         ELSEIF ( ICAse==1 .OR. ICAse==2 .OR. ICAse==5 .OR.             &
     &            ICAse==6 .OR. ICAse==12 .OR. ICAse==13 ) THEN
            CALL CHECK2(sfac)
         ELSEIF ( ICAse==4 ) THEN
            CALL CHECK3(sfac)
         ENDIF
!        -- Print
         IF ( PASs ) WRITE (NOUT,99002)
99002    FORMAT ('                                    ----- PASS -----')
      ENDDO
      STOP
      END PROGRAM SBLAT1
!*==header.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE HEADER
      IMPLICIT NONE
!*--HEADER102
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , N
      LOGICAL PASs
!     .. Local Arrays ..
      CHARACTER*6 l(13)
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , PASs
!     .. Data statements ..
      DATA l(1)/' SDOT '/
      DATA l(2)/'SAXPY '/
      DATA l(3)/'SROTG '/
      DATA l(4)/' SROT '/
      DATA l(5)/'SCOPY '/
      DATA l(6)/'SSWAP '/
      DATA l(7)/'SNRM2 '/
      DATA l(8)/'SASUM '/
      DATA l(9)/'SSCAL '/
      DATA l(10)/'ISAMAX'/
      DATA l(11)/'SROTMG'/
      DATA l(12)/'SROTM '/
      DATA l(13)/'SDSDOT'/
!     .. Executable Statements ..
      WRITE (NOUT,99001) ICAse , l(ICAse)
!
99001 FORMAT (/' Test of subprogram number',I3,12X,A6)
      RETURN
      END SUBROUTINE HEADER
!*==check0.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE CHECK0(Sfac)
      IMPLICIT NONE
!*--CHECK0136
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalar Arguments ..
      REAL Sfac
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , N
      LOGICAL PASs
!     .. Local Scalars ..
      REAL d12 , sa , sb , sc , ss
      INTEGER i , k
!     .. Local Arrays ..
      REAL da1(8) , datrue(8) , db1(8) , dbtrue(8) , dc1(8) , ds1(8) ,  &
     &     dab(4,9) , dtemp(9) , dtrue(9,9)
!     .. External Subroutines ..
      EXTERNAL SROTG , SROTMG , STEST , STEST1
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , PASs
!     .. Data statements ..
      DATA da1/0.3E0 , 0.4E0 , -0.3E0 , -0.4E0 , -0.3E0 , 0.0E0 ,       &
     &     0.0E0 , 1.0E0/
      DATA db1/0.4E0 , 0.3E0 , 0.4E0 , 0.3E0 , -0.4E0 , 0.0E0 , 1.0E0 , &
     &     0.0E0/
      DATA dc1/0.6E0 , 0.8E0 , -0.6E0 , 0.8E0 , 0.6E0 , 1.0E0 , 0.0E0 , &
     &     1.0E0/
      DATA ds1/0.8E0 , 0.6E0 , 0.8E0 , -0.6E0 , 0.8E0 , 0.0E0 , 1.0E0 , &
     &     0.0E0/
      DATA datrue/0.5E0 , 0.5E0 , 0.5E0 , -0.5E0 , -0.5E0 , 0.0E0 ,     &
     &     1.0E0 , 1.0E0/
      DATA dbtrue/0.0E0 , 0.6E0 , 0.0E0 , -0.6E0 , 0.0E0 , 0.0E0 ,      &
     &     1.0E0 , 0.0E0/
!     INPUT FOR MODIFIED GIVENS
      DATA dab/.1E0 , .3E0 , 1.2E0 , .2E0 , .7E0 , .2E0 , .6E0 , 4.2E0 ,&
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , 4.E0 , -1.E0 , 2.E0 , 4.E0 ,     &
     &     6.E-10 , 2.E-2 , 1.E5 , 10.E0 , 4.E10 , 2.E-2 , 1.E-5 ,      &
     &     10.E0 , 2.E-10 , 4.E-2 , 1.E5 , 10.E0 , 2.E10 , 4.E-2 ,      &
     &     1.E-5 , 10.E0 , 4.E0 , -2.E0 , 8.E0 , 4.E0/
!    TRUE RESULTS FOR MODIFIED GIVENS
      DATA dtrue/0.E0 , 0.E0 , 1.3E0 , .2E0 , 0.E0 , 0.E0 , 0.E0 ,      &
     &     .5E0 , 0.E0 , 0.E0 , 0.E0 , 4.5E0 , 4.2E0 , 1.E0 , .5E0 ,    &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , -2.E0 ,     &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 4.E0 ,      &
     &     -1.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 15.E-3 , 0.E0 ,   &
     &     10.E0 , -1.E0 , 0.E0 , -1.E-4 , 0.E0 , 1.E0 , 0.E0 , 0.E0 ,  &
     &     6144.E-5 , 10.E0 , -1.E0 , 4096.E0 , -1.E6 , 0.E0 , 1.E0 ,   &
     &     0.E0 , 0.E0 , 15.E0 , 10.E0 , -1.E0 , 5.E-5 , 0.E0 , 1.E0 ,  &
     &     0.E0 , 0.E0 , 0.E0 , 15.E0 , 10.E0 , -1.E0 , 5.E5 ,          &
     &     -4096.E0 , 1.E0 , 4096.E-6 , 0.E0 , 0.E0 , 7.E0 , 4.E0 ,     &
     &     0.E0 , 0.E0 , -.5E0 , -.25E0 , 0.E0/
!                   4096 = 2 ** 12
      DATA d12/4096.E0/
      dtrue(1,1) = 12.E0/130.E0
      dtrue(2,1) = 36.E0/130.E0
      dtrue(7,1) = -1.E0/6.E0
      dtrue(1,2) = 14.E0/75.E0
      dtrue(2,2) = 49.E0/75.E0
      dtrue(9,2) = 1.E0/7.E0
      dtrue(1,5) = 45.E-11*(d12*d12)
      dtrue(3,5) = 4.E5/(3.E0*d12)
      dtrue(6,5) = 1.E0/d12
      dtrue(8,5) = 1.E4/(3.E0*d12)
      dtrue(1,6) = 4.E10/(1.5E0*d12*d12)
      dtrue(2,6) = 2.E-2/1.5E0
      dtrue(8,6) = 5.E-7*d12
      dtrue(1,7) = 4.E0/150.E0
      dtrue(2,7) = (2.E-10/1.5E0)*(d12*d12)
      dtrue(7,7) = -dtrue(6,5)
      dtrue(9,7) = 1.E4/d12
      dtrue(1,8) = dtrue(1,7)
      dtrue(2,8) = 2.E10/(1.5E0*d12*d12)
      dtrue(1,9) = 32.E0/7.E0
      dtrue(2,9) = -16.E0/7.E0
!     .. Executable Statements ..
!
!     Compute true values which cannot be prestored
!     in decimal notation
!
      dbtrue(1) = 1.0E0/0.6E0
      dbtrue(3) = -1.0E0/0.6E0
      dbtrue(5) = 1.0E0/0.6E0
!
      DO k = 1 , 8
!        .. Set N=K for identification in output if any ..
         N = k
         IF ( ICAse==3 ) THEN
!           .. SROTG ..
            IF ( k>8 ) EXIT
            sa = da1(k)
            sb = db1(k)
            CALL SROTG(sa,sb,sc,ss)
            CALL STEST1(sa,datrue(k),datrue(k),Sfac)
            CALL STEST1(sb,dbtrue(k),dbtrue(k),Sfac)
            CALL STEST1(sc,dc1(k),dc1(k),Sfac)
            CALL STEST1(ss,ds1(k),ds1(k),Sfac)
         ELSEIF ( ICAse==11 ) THEN
!           .. SROTMG ..
            DO i = 1 , 4
               dtemp(i) = dab(i,k)
               dtemp(i+4) = 0.0
            ENDDO
            dtemp(9) = 0.0
            CALL SROTMG(dtemp(1),dtemp(2),dtemp(3),dtemp(4),dtemp(5))
            CALL STEST(9,dtemp,dtrue(1,k),dtrue(1,k),Sfac)
         ELSE
            WRITE (NOUT,*) ' Shouldn''t be here in CHECK0'
            STOP
         ENDIF
      ENDDO
      END SUBROUTINE CHECK0
!*==check1.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE CHECK1(Sfac)
      IMPLICIT NONE
!*--CHECK1249
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalar Arguments ..
      REAL Sfac
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , N
      LOGICAL PASs
!     .. Local Scalars ..
      INTEGER i , ix , len , np1
!     .. Local Arrays ..
      REAL dtrue1(5) , dtrue3(5) , dtrue5(8,5,2) , dv(8,5,2) , dvr(8) , &
     &     sa(10) , stemp(1) , strue(8) , sx(8) , sxr(15)
      INTEGER itrue2(5) , itruec(5)
!     .. External Functions ..
      REAL SASUM , SNRM2
      INTEGER ISAMAX
      EXTERNAL SASUM , SNRM2 , ISAMAX
!     .. External Subroutines ..
      EXTERNAL ITEST1 , SSCAL , STEST , STEST1
!     .. Intrinsic Functions ..
      INTRINSIC MAX
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , PASs
!     .. Data statements ..
      DATA sa/0.3E0 , -1.0E0 , 0.0E0 , 1.0E0 , 0.3E0 , 0.3E0 , 0.3E0 ,  &
     &     0.3E0 , 0.3E0 , 0.3E0/
      DATA dv/0.1E0 , 2.0E0 , 2.0E0 , 2.0E0 , 2.0E0 , 2.0E0 , 2.0E0 ,   &
     &     2.0E0 , 0.3E0 , 3.0E0 , 3.0E0 , 3.0E0 , 3.0E0 , 3.0E0 ,      &
     &     3.0E0 , 3.0E0 , 0.3E0 , -0.4E0 , 4.0E0 , 4.0E0 , 4.0E0 ,     &
     &     4.0E0 , 4.0E0 , 4.0E0 , 0.2E0 , -0.6E0 , 0.3E0 , 5.0E0 ,     &
     &     5.0E0 , 5.0E0 , 5.0E0 , 5.0E0 , 0.1E0 , -0.3E0 , 0.5E0 ,     &
     &     -0.1E0 , 6.0E0 , 6.0E0 , 6.0E0 , 6.0E0 , 0.1E0 , 8.0E0 ,     &
     &     8.0E0 , 8.0E0 , 8.0E0 , 8.0E0 , 8.0E0 , 8.0E0 , 0.3E0 ,      &
     &     9.0E0 , 9.0E0 , 9.0E0 , 9.0E0 , 9.0E0 , 9.0E0 , 9.0E0 ,      &
     &     0.3E0 , 2.0E0 , -0.4E0 , 2.0E0 , 2.0E0 , 2.0E0 , 2.0E0 ,     &
     &     2.0E0 , 0.2E0 , 3.0E0 , -0.6E0 , 5.0E0 , 0.3E0 , 2.0E0 ,     &
     &     2.0E0 , 2.0E0 , 0.1E0 , 4.0E0 , -0.3E0 , 6.0E0 , -0.5E0 ,    &
     &     7.0E0 , -0.1E0 , 3.0E0/
      DATA dvr/8.0E0 , -7.0E0 , 9.0E0 , 5.0E0 , 9.0E0 , 8.0E0 , 7.0E0 , &
     &     7.0E0/
      DATA dtrue1/0.0E0 , 0.3E0 , 0.5E0 , 0.7E0 , 0.6E0/
      DATA dtrue3/0.0E0 , 0.3E0 , 0.7E0 , 1.1E0 , 1.0E0/
      DATA dtrue5/0.10E0 , 2.0E0 , 2.0E0 , 2.0E0 , 2.0E0 , 2.0E0 ,      &
     &     2.0E0 , 2.0E0 , -0.3E0 , 3.0E0 , 3.0E0 , 3.0E0 , 3.0E0 ,     &
     &     3.0E0 , 3.0E0 , 3.0E0 , 0.0E0 , 0.0E0 , 4.0E0 , 4.0E0 ,      &
     &     4.0E0 , 4.0E0 , 4.0E0 , 4.0E0 , 0.20E0 , -0.60E0 , 0.30E0 ,  &
     &     5.0E0 , 5.0E0 , 5.0E0 , 5.0E0 , 5.0E0 , 0.03E0 , -0.09E0 ,   &
     &     0.15E0 , -0.03E0 , 6.0E0 , 6.0E0 , 6.0E0 , 6.0E0 , 0.10E0 ,  &
     &     8.0E0 , 8.0E0 , 8.0E0 , 8.0E0 , 8.0E0 , 8.0E0 , 8.0E0 ,      &
     &     0.09E0 , 9.0E0 , 9.0E0 , 9.0E0 , 9.0E0 , 9.0E0 , 9.0E0 ,     &
     &     9.0E0 , 0.09E0 , 2.0E0 , -0.12E0 , 2.0E0 , 2.0E0 , 2.0E0 ,   &
     &     2.0E0 , 2.0E0 , 0.06E0 , 3.0E0 , -0.18E0 , 5.0E0 , 0.09E0 ,  &
     &     2.0E0 , 2.0E0 , 2.0E0 , 0.03E0 , 4.0E0 , -0.09E0 , 6.0E0 ,   &
     &     -0.15E0 , 7.0E0 , -0.03E0 , 3.0E0/
      DATA itrue2/0 , 1 , 2 , 2 , 3/
      DATA itruec/0 , 1 , 1 , 1 , 1/
!     .. Executable Statements ..
      DO INCx = 1 , 2
         DO np1 = 1 , 5
            N = np1 - 1
            len = 2*MAX(N,1)
!           .. Set vector arguments ..
            DO i = 1 , len
               sx(i) = dv(i,np1,INCx)
            ENDDO
!
            IF ( ICAse==7 ) THEN
!              .. SNRM2 ..
               stemp(1) = dtrue1(np1)
               CALL STEST1(SNRM2(N,sx,INCx),stemp(1),stemp,Sfac)
            ELSEIF ( ICAse==8 ) THEN
!              .. SASUM ..
               stemp(1) = dtrue3(np1)
               CALL STEST1(SASUM(N,sx,INCx),stemp(1),stemp,Sfac)
            ELSEIF ( ICAse==9 ) THEN
!              .. SSCAL ..
               CALL SSCAL(N,sa((INCx-1)*5+np1),sx,INCx)
               DO i = 1 , len
                  strue(i) = dtrue5(i,np1,INCx)
               ENDDO
               CALL STEST(len,sx,strue,strue,Sfac)
            ELSEIF ( ICAse==10 ) THEN
!              .. ISAMAX ..
               CALL ITEST1(ISAMAX(N,sx,INCx),itrue2(np1))
               DO i = 1 , len
                  sx(i) = 42.0E0
               ENDDO
               CALL ITEST1(ISAMAX(N,sx,INCx),itruec(np1))
            ELSE
               WRITE (NOUT,*) ' Shouldn''t be here in CHECK1'
               STOP
            ENDIF
         ENDDO
         IF ( ICAse==10 ) THEN
            N = 8
            ix = 1
            DO i = 1 , N
               sxr(ix) = dvr(i)
               ix = ix + INCx
            ENDDO
            CALL ITEST1(ISAMAX(N,sxr,INCx),3)
         ENDIF
      ENDDO
      END SUBROUTINE CHECK1
!*==check2.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE CHECK2(Sfac)
      IMPLICIT NONE
!*--CHECK2358
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalar Arguments ..
      REAL Sfac
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , N
      LOGICAL PASs
!     .. Local Scalars ..
      REAL sa
      INTEGER i , j , ki , kn , kni , kpar , ksize , lenx , leny ,      &
     &        lincx , lincy , mx , my
!     .. Local Arrays ..
      REAL dt10x(7,4,4) , dt10y(7,4,4) , dt7(4,4) , dt8(7,4,4) , dx1(7) &
     &     , dy1(7) , ssize1(4) , ssize2(14,2) , ssize3(4) , ssize(7) , &
     &     stx(7) , sty(7) , sx(7) , sy(7) , dpar(5,4) , dt19x(7,4,16) ,&
     &     dt19xa(7,4,4) , dt19xb(7,4,4) , dt19xc(7,4,4) , dt19xd(7,4,4)&
     &     , dt19y(7,4,16) , dt19ya(7,4,4) , dt19yb(7,4,4) ,            &
     &     dt19yc(7,4,4) , dt19yd(7,4,4) , dtemp(5) , st7b(4,4) ,       &
     &     sty0(1) , sx0(1) , sy0(1)
      INTEGER incxs(4) , incys(4) , lens(4,2) , ns(4)
!     .. External Functions ..
      REAL SDOT , SDSDOT
      EXTERNAL SDOT , SDSDOT
!     .. External Subroutines ..
      EXTERNAL SAXPY , SCOPY , SROTM , SSWAP , STEST , STEST1
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MIN
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , PASs
!     .. Data statements ..
      EQUIVALENCE (dt19x(1,1,1),dt19xa(1,1,1))
      EQUIVALENCE (dt19x(1,1,5),dt19xb(1,1,1))
      EQUIVALENCE (dt19x(1,1,9),dt19xc(1,1,1))
      EQUIVALENCE (dt19x(1,1,13),dt19xd(1,1,1))
      EQUIVALENCE (dt19y(1,1,1),dt19ya(1,1,1))
      EQUIVALENCE (dt19y(1,1,5),dt19yb(1,1,1))
      EQUIVALENCE (dt19y(1,1,9),dt19yc(1,1,1))
      EQUIVALENCE (dt19y(1,1,13),dt19yd(1,1,1))

      DATA sa/0.3E0/
      DATA incxs/1 , 2 , -2 , -1/
      DATA incys/1 , -2 , 1 , -2/
      DATA lens/1 , 1 , 2 , 4 , 1 , 1 , 3 , 7/
      DATA ns/0 , 1 , 2 , 4/
      DATA dx1/0.6E0 , 0.1E0 , -0.5E0 , 0.8E0 , 0.9E0 , -0.3E0 , -0.4E0/
      DATA dy1/0.5E0 , -0.9E0 , 0.3E0 , 0.7E0 , -0.6E0 , 0.2E0 , 0.8E0/
      DATA dt7/0.0E0 , 0.30E0 , 0.21E0 , 0.62E0 , 0.0E0 , 0.30E0 ,      &
     &     -0.07E0 , 0.85E0 , 0.0E0 , 0.30E0 , -0.79E0 , -0.74E0 ,      &
     &     0.0E0 , 0.30E0 , 0.33E0 , 1.27E0/
      DATA st7b/.1 , .4 , .31 , .72 , .1 , .4 , .03 , .95 , .1 , .4 ,   &
     &     -.69 , -.64 , .1 , .4 , .43 , 1.37/
      DATA dt8/0.5E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,  &
     &     0.68E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,     &
     &     0.68E0 , -0.87E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,   &
     &     0.68E0 , -0.87E0 , 0.15E0 , 0.94E0 , 0.0E0 , 0.0E0 , 0.0E0 , &
     &     0.5E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     0.68E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,     &
     &     0.35E0 , -0.9E0 , 0.48E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,   &
     &     0.38E0 , -0.9E0 , 0.57E0 , 0.7E0 , -0.75E0 , 0.2E0 , 0.98E0 ,&
     &     0.5E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     0.68E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,     &
     &     0.35E0 , -0.72E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,   &
     &     0.38E0 , -0.63E0 , 0.15E0 , 0.88E0 , 0.0E0 , 0.0E0 , 0.0E0 , &
     &     0.5E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     0.68E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,     &
     &     0.68E0 , -0.9E0 , 0.33E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,   &
     &     0.68E0 , -0.9E0 , 0.33E0 , 0.7E0 , -0.75E0 , 0.2E0 , 1.04E0/
      DATA dt10x/0.6E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,&
     &     0.5E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     0.5E0 , -0.9E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,     &
     &     0.5E0 , -0.9E0 , 0.3E0 , 0.7E0 , 0.0E0 , 0.0E0 , 0.0E0 ,     &
     &     0.6E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     0.5E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     0.3E0 , 0.1E0 , 0.5E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     0.8E0 , 0.1E0 , -0.6E0 , 0.8E0 , 0.3E0 , -0.3E0 , 0.5E0 ,    &
     &     0.6E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     0.5E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     -0.9E0 , 0.1E0 , 0.5E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,     &
     &     0.7E0 , 0.1E0 , 0.3E0 , 0.8E0 , -0.9E0 , -0.3E0 , 0.5E0 ,    &
     &     0.6E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     0.5E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     0.5E0 , 0.3E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     0.5E0 , 0.3E0 , -0.6E0 , 0.8E0 , 0.0E0 , 0.0E0 , 0.0E0/
      DATA dt10y/0.5E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,&
     &     0.6E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     0.6E0 , 0.1E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     0.6E0 , 0.1E0 , -0.5E0 , 0.8E0 , 0.0E0 , 0.0E0 , 0.0E0 ,     &
     &     0.5E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     0.6E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     -0.5E0 , -0.9E0 , 0.6E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,    &
     &     -0.4E0 , -0.9E0 , 0.9E0 , 0.7E0 , -0.5E0 , 0.2E0 , 0.6E0 ,   &
     &     0.5E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     0.6E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     -0.5E0 , 0.6E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,     &
     &     -0.4E0 , 0.9E0 , -0.5E0 , 0.6E0 , 0.0E0 , 0.0E0 , 0.0E0 ,    &
     &     0.5E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     0.6E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     0.6E0 , -0.9E0 , 0.1E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,     &
     &     0.6E0 , -0.9E0 , 0.1E0 , 0.7E0 , -0.5E0 , 0.2E0 , 0.8E0/
      DATA ssize1/0.0E0 , 0.3E0 , 1.6E0 , 3.2E0/
      DATA ssize2/0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,       &
     &     0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     0.0E0 , 1.17E0 , 1.17E0 , 1.17E0 , 1.17E0 , 1.17E0 , 1.17E0 ,&
     &     1.17E0 , 1.17E0 , 1.17E0 , 1.17E0 , 1.17E0 , 1.17E0 ,        &
     &     1.17E0 , 1.17E0/
      DATA ssize3/.1 , .4 , 1.7 , 3.3/
!
!                         FOR DROTM
!
      DATA dpar/ - 2.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , -1.E0 , 2.E0 ,    &
     &     -3.E0 , -4.E0 , 5.E0 , 0.E0 , 0.E0 , 2.E0 , -3.E0 , 0.E0 ,   &
     &     1.E0 , 5.E0 , 2.E0 , 0.E0 , -4.E0/
!                        TRUE X RESULTS F0R ROTATIONS DROTM
      DATA dt19xa/.6E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,      &
     &     .6E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .6E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .6E0 , 0.E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .6E0 , 0.E0 , 0.E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , -.8E0 , 0.E0 , 0.E0 , 0.E0 ,     &
     &     0.E0 , 0.E0 , 0.E0 , -.9E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,     &
     &     0.E0 , 0.E0 , 3.5E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,     &
     &     0.E0 , .6E0 , .1E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,      &
     &     -.8E0 , 3.8E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , -.9E0 ,   &
     &     2.8E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 3.5E0 , -.4E0 ,   &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .6E0 , .1E0 , -.5E0 ,     &
     &     .8E0 , 0.E0 , 0.E0 , 0.E0 , -.8E0 , 3.8E0 , -2.2E0 , -1.2E0 ,&
     &     0.E0 , 0.E0 , 0.E0 , -.9E0 , 2.8E0 , -1.4E0 , -1.3E0 , 0.E0 ,&
     &     0.E0 , 0.E0 , 3.5E0 , -.4E0 , -2.2E0 , 4.7E0 , 0.E0 , 0.E0 , &
     &     0.E0/
!
      DATA dt19xb/.6E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,      &
     &     .6E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .6E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .6E0 , 0.E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .6E0 , 0.E0 , 0.E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , -.8E0 , 0.E0 , 0.E0 , 0.E0 ,     &
     &     0.E0 , 0.E0 , 0.E0 , -.9E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,     &
     &     0.E0 , 0.E0 , 3.5E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,     &
     &     0.E0 , .6E0 , .1E0 , -.5E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,     &
     &     0.E0 , .1E0 , -3.0E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , -.3E0 ,   &
     &     .1E0 , -2.0E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 3.3E0 , .1E0 ,   &
     &     -2.0E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .6E0 , .1E0 , -.5E0 ,   &
     &     .8E0 , .9E0 , -.3E0 , -.4E0 , -2.0E0 , .1E0 , 1.4E0 , .8E0 , &
     &     .6E0 , -.3E0 , -2.8E0 , -1.8E0 , .1E0 , 1.3E0 , .8E0 , 0.E0 ,&
     &     -.3E0 , -1.9E0 , 3.8E0 , .1E0 , -3.1E0 , .8E0 , 4.8E0 ,      &
     &     -.3E0 , -1.5E0/
!
      DATA dt19xc/.6E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,      &
     &     .6E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .6E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .6E0 , 0.E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .6E0 , 0.E0 , 0.E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , -.8E0 , 0.E0 , 0.E0 , 0.E0 ,     &
     &     0.E0 , 0.E0 , 0.E0 , -.9E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,     &
     &     0.E0 , 0.E0 , 3.5E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,     &
     &     0.E0 , .6E0 , .1E0 , -.5E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,     &
     &     4.8E0 , .1E0 , -3.0E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 3.3E0 ,  &
     &     .1E0 , -2.0E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 2.1E0 , .1E0 ,   &
     &     -2.0E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .6E0 , .1E0 , -.5E0 ,   &
     &     .8E0 , .9E0 , -.3E0 , -.4E0 , -1.6E0 , .1E0 , -2.2E0 , .8E0 ,&
     &     5.4E0 , -.3E0 , -2.8E0 , -1.5E0 , .1E0 , -1.4E0 , .8E0 ,     &
     &     3.6E0 , -.3E0 , -1.9E0 , 3.7E0 , .1E0 , -2.2E0 , .8E0 ,      &
     &     3.6E0 , -.3E0 , -1.5E0/
!
      DATA dt19xd/.6E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,      &
     &     .6E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .6E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .6E0 , 0.E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .6E0 , 0.E0 , 0.E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , -.8E0 , 0.E0 , 0.E0 , 0.E0 ,     &
     &     0.E0 , 0.E0 , 0.E0 , -.9E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,     &
     &     0.E0 , 0.E0 , 3.5E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,     &
     &     0.E0 , .6E0 , .1E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,      &
     &     -.8E0 , -1.0E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , -.9E0 ,  &
     &     -.8E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 3.5E0 , .8E0 ,    &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .6E0 , .1E0 , -.5E0 ,     &
     &     .8E0 , 0.E0 , 0.E0 , 0.E0 , -.8E0 , -1.0E0 , 1.4E0 , -1.6E0 ,&
     &     0.E0 , 0.E0 , 0.E0 , -.9E0 , -.8E0 , 1.3E0 , -1.6E0 , 0.E0 , &
     &     0.E0 , 0.E0 , 3.5E0 , .8E0 , -3.1E0 , 4.8E0 , 0.E0 , 0.E0 ,  &
     &     0.E0/
!                        TRUE Y RESULTS FOR ROTATIONS DROTM
      DATA dt19ya/.5E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,      &
     &     .5E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .5E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .5E0 , 0.E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .5E0 , 0.E0 , 0.E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , .7E0 , 0.E0 , 0.E0 , 0.E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 1.7E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,     &
     &     0.E0 , 0.E0 , -2.6E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,    &
     &     0.E0 , .5E0 , -.9E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,     &
     &     .7E0 , -4.8E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 1.7E0 ,   &
     &     -.7E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , -2.6E0 , 3.5E0 ,  &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .5E0 , -.9E0 , .3E0 ,     &
     &     .7E0 , 0.E0 , 0.E0 , 0.E0 , .7E0 , -4.8E0 , 3.0E0 , 1.1E0 ,  &
     &     0.E0 , 0.E0 , 0.E0 , 1.7E0 , -.7E0 , -.7E0 , 2.3E0 , 0.E0 ,  &
     &     0.E0 , 0.E0 , -2.6E0 , 3.5E0 , -.7E0 , -3.6E0 , 0.E0 , 0.E0 ,&
     &     0.E0/
!
      DATA dt19yb/.5E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,      &
     &     .5E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .5E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .5E0 , 0.E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .5E0 , 0.E0 , 0.E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , .7E0 , 0.E0 , 0.E0 , 0.E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 1.7E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,     &
     &     0.E0 , 0.E0 , -2.6E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,    &
     &     0.E0 , .5E0 , -.9E0 , .3E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,     &
     &     4.0E0 , -.9E0 , -.3E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , -.5E0 ,  &
     &     -.9E0 , 1.5E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , -1.5E0 , -.9E0 , &
     &     -1.8E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .5E0 , -.9E0 , .3E0 ,   &
     &     .7E0 , -.6E0 , .2E0 , .8E0 , 3.7E0 , -.9E0 , -1.2E0 , .7E0 , &
     &     -1.5E0 , .2E0 , 2.2E0 , -.3E0 , -.9E0 , 2.1E0 , .7E0 ,       &
     &     -1.6E0 , .2E0 , 2.0E0 , -1.6E0 , -.9E0 , -2.1E0 , .7E0 ,     &
     &     2.9E0 , .2E0 , -3.8E0/
!
      DATA dt19yc/.5E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,      &
     &     .5E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .5E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .5E0 , 0.E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .5E0 , 0.E0 , 0.E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , .7E0 , 0.E0 , 0.E0 , 0.E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 1.7E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,     &
     &     0.E0 , 0.E0 , -2.6E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,    &
     &     0.E0 , .5E0 , -.9E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,     &
     &     4.0E0 , -6.3E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , -.5E0 ,  &
     &     .3E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , -1.5E0 , 3.0E0 ,   &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .5E0 , -.9E0 , .3E0 ,     &
     &     .7E0 , 0.E0 , 0.E0 , 0.E0 , 3.7E0 , -7.2E0 , 3.0E0 , 1.7E0 , &
     &     0.E0 , 0.E0 , 0.E0 , -.3E0 , .9E0 , -.7E0 , 1.9E0 , 0.E0 ,   &
     &     0.E0 , 0.E0 , -1.6E0 , 2.7E0 , -.7E0 , -3.4E0 , 0.E0 , 0.E0 ,&
     &     0.E0/
!
      DATA dt19yd/.5E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,      &
     &     .5E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .5E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .5E0 , 0.E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .5E0 , 0.E0 , 0.E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 0.E0 , .7E0 , 0.E0 , 0.E0 , 0.E0 ,      &
     &     0.E0 , 0.E0 , 0.E0 , 1.7E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,     &
     &     0.E0 , 0.E0 , -2.6E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,    &
     &     0.E0 , .5E0 , -.9E0 , .3E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 ,     &
     &     .7E0 , -.9E0 , 1.2E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , 1.7E0 ,   &
     &     -.9E0 , .5E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , -2.6E0 , -.9E0 ,  &
     &     -1.3E0 , 0.E0 , 0.E0 , 0.E0 , 0.E0 , .5E0 , -.9E0 , .3E0 ,   &
     &     .7E0 , -.6E0 , .2E0 , .8E0 , .7E0 , -.9E0 , 1.2E0 , .7E0 ,   &
     &     -1.5E0 , .2E0 , 1.6E0 , 1.7E0 , -.9E0 , .5E0 , .7E0 ,        &
     &     -1.6E0 , .2E0 , 2.4E0 , -2.6E0 , -.9E0 , -1.3E0 , .7E0 ,     &
     &     2.9E0 , .2E0 , -4.0E0/
!
!     .. Executable Statements ..
!
      DO ki = 1 , 4
         INCx = incxs(ki)
         INCy = incys(ki)
         mx = ABS(INCx)
         my = ABS(INCy)
!
         DO kn = 1 , 4
            N = ns(kn)
            ksize = MIN(2,kn)
            lenx = lens(kn,mx)
            leny = lens(kn,my)
!           .. Initialize all argument arrays ..
            DO i = 1 , 7
               sx(i) = dx1(i)
               sy(i) = dy1(i)
            ENDDO
!
            IF ( ICAse==1 ) THEN
!              .. SDOT ..
               CALL STEST1(SDOT(N,sx,INCx,sy,INCy),dt7(kn,ki),ssize1(kn)&
     &                     ,Sfac)
            ELSEIF ( ICAse==2 ) THEN
!              .. SAXPY ..
               CALL SAXPY(N,sa,sx,INCx,sy,INCy)
               DO j = 1 , leny
                  sty(j) = dt8(j,kn,ki)
               ENDDO
               CALL STEST(leny,sy,sty,ssize2(1,ksize),Sfac)
            ELSEIF ( ICAse==5 ) THEN
!              .. SCOPY ..
               DO i = 1 , 7
                  sty(i) = dt10y(i,kn,ki)
               ENDDO
               CALL SCOPY(N,sx,INCx,sy,INCy)
               CALL STEST(leny,sy,sty,ssize2(1,1),1.0E0)
               IF ( ki==1 ) THEN
                  sx0(1) = 42.0E0
                  sy0(1) = 43.0E0
                  IF ( N==0 ) THEN
                     sty0(1) = sy0(1)
                  ELSE
                     sty0(1) = sx0(1)
                  ENDIF
                  lincx = INCx
                  INCx = 0
                  lincy = INCy
                  INCy = 0
                  CALL SCOPY(N,sx0,INCx,sy0,INCy)
                  CALL STEST(1,sy0,sty0,ssize2(1,1),1.0E0)
                  INCx = lincx
                  INCy = lincy
               ENDIF
            ELSEIF ( ICAse==6 ) THEN
!              .. SSWAP ..
               CALL SSWAP(N,sx,INCx,sy,INCy)
               DO i = 1 , 7
                  stx(i) = dt10x(i,kn,ki)
                  sty(i) = dt10y(i,kn,ki)
               ENDDO
               CALL STEST(lenx,sx,stx,ssize2(1,1),1.0E0)
               CALL STEST(leny,sy,sty,ssize2(1,1),1.0E0)
            ELSEIF ( ICAse==12 ) THEN
!              .. SROTM ..
               kni = kn + 4*(ki-1)
               DO kpar = 1 , 4
                  DO i = 1 , 7
                     sx(i) = dx1(i)
                     sy(i) = dy1(i)
                     stx(i) = dt19x(i,kpar,kni)
                     sty(i) = dt19y(i,kpar,kni)
                  ENDDO
!
                  DO i = 1 , 5
                     dtemp(i) = dpar(i,kpar)
                  ENDDO
!
                  DO i = 1 , lenx
                     ssize(i) = stx(i)
                  ENDDO
!                   SEE REMARK ABOVE ABOUT DT11X(1,2,7)
!                       AND DT11X(5,3,8).
                  IF ( (kpar==2) .AND. (kni==7) ) ssize(1) = 2.4E0
                  IF ( (kpar==3) .AND. (kni==8) ) ssize(5) = 1.8E0
!
                  CALL SROTM(N,sx,INCx,sy,INCy,dtemp)
                  CALL STEST(lenx,sx,stx,ssize,Sfac)
                  CALL STEST(leny,sy,sty,sty,Sfac)
               ENDDO
            ELSEIF ( ICAse==13 ) THEN
!              .. SDSROT ..
               CALL STEST1(SDSDOT(N,.1,sx,INCx,sy,INCy),st7b(kn,ki),    &
     &                     ssize3(kn),Sfac)
            ELSE
               WRITE (NOUT,*) ' Shouldn''t be here in CHECK2'
               STOP
            ENDIF
         ENDDO
      ENDDO
      END SUBROUTINE CHECK2
!*==check3.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE CHECK3(Sfac)
      IMPLICIT NONE
!*--CHECK3705
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalar Arguments ..
      REAL Sfac
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , N
      LOGICAL PASs
!     .. Local Scalars ..
      REAL sc , ss
      INTEGER i , k , ki , kn , ksize , lenx , leny , mx , my
!     .. Local Arrays ..
      REAL copyx(5) , copyy(5) , dt9x(7,4,4) , dt9y(7,4,4) , dx1(7) ,   &
     &     dy1(7) , mwpc(11) , mwps(11) , mwpstx(5) , mwpsty(5) ,       &
     &     mwptx(11,5) , mwpty(11,5) , mwpx(5) , mwpy(5) , ssize2(14,2) &
     &     , stx(7) , sty(7) , sx(7) , sy(7)
      INTEGER incxs(4) , incys(4) , lens(4,2) , mwpinx(11) , mwpiny(11) &
     &        , mwpn(11) , ns(4)
!     .. External Subroutines ..
      EXTERNAL SROT , STEST
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MIN
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , PASs
!     .. Data statements ..
      DATA incxs/1 , 2 , -2 , -1/
      DATA incys/1 , -2 , 1 , -2/
      DATA lens/1 , 1 , 2 , 4 , 1 , 1 , 3 , 7/
      DATA ns/0 , 1 , 2 , 4/
      DATA dx1/0.6E0 , 0.1E0 , -0.5E0 , 0.8E0 , 0.9E0 , -0.3E0 , -0.4E0/
      DATA dy1/0.5E0 , -0.9E0 , 0.3E0 , 0.7E0 , -0.6E0 , 0.2E0 , 0.8E0/
      DATA sc , ss/0.8E0 , 0.6E0/
      DATA dt9x/0.6E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , &
     &     0.78E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,     &
     &     0.78E0 , -0.46E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,   &
     &     0.78E0 , -0.46E0 , -0.22E0 , 1.06E0 , 0.0E0 , 0.0E0 , 0.0E0 ,&
     &     0.6E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     0.78E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,     &
     &     0.66E0 , 0.1E0 , -0.1E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,    &
     &     0.96E0 , 0.1E0 , -0.76E0 , 0.8E0 , 0.90E0 , -0.3E0 ,         &
     &     -0.02E0 , 0.6E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,    &
     &     0.0E0 , 0.78E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,     &
     &     0.0E0 , -0.06E0 , 0.1E0 , -0.1E0 , 0.0E0 , 0.0E0 , 0.0E0 ,   &
     &     0.0E0 , 0.90E0 , 0.1E0 , -0.22E0 , 0.8E0 , 0.18E0 , -0.3E0 , &
     &     -0.02E0 , 0.6E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,    &
     &     0.0E0 , 0.78E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,     &
     &     0.0E0 , 0.78E0 , 0.26E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,    &
     &     0.0E0 , 0.78E0 , 0.26E0 , -0.76E0 , 1.12E0 , 0.0E0 , 0.0E0 , &
     &     0.0E0/
      DATA dt9y/0.5E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , &
     &     0.04E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,     &
     &     0.04E0 , -0.78E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,   &
     &     0.04E0 , -0.78E0 , 0.54E0 , 0.08E0 , 0.0E0 , 0.0E0 , 0.0E0 , &
     &     0.5E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     0.04E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,     &
     &     0.7E0 , -0.9E0 , -0.12E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,   &
     &     0.64E0 , -0.9E0 , -0.30E0 , 0.7E0 , -0.18E0 , 0.2E0 ,        &
     &     0.28E0 , 0.5E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,     &
     &     0.0E0 , 0.04E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,     &
     &     0.0E0 , 0.7E0 , -1.08E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,    &
     &     0.0E0 , 0.64E0 , -1.26E0 , 0.54E0 , 0.20E0 , 0.0E0 , 0.0E0 , &
     &     0.0E0 , 0.5E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     0.0E0 , 0.04E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,     &
     &     0.0E0 , 0.04E0 , -0.9E0 , 0.18E0 , 0.0E0 , 0.0E0 , 0.0E0 ,   &
     &     0.0E0 , 0.04E0 , -0.9E0 , 0.18E0 , 0.7E0 , -0.18E0 , 0.2E0 , &
     &     0.16E0/
      DATA ssize2/0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,       &
     &     0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 , 0.0E0 ,      &
     &     0.0E0 , 1.17E0 , 1.17E0 , 1.17E0 , 1.17E0 , 1.17E0 , 1.17E0 ,&
     &     1.17E0 , 1.17E0 , 1.17E0 , 1.17E0 , 1.17E0 , 1.17E0 ,        &
     &     1.17E0 , 1.17E0/
!     .. Executable Statements ..
!
      DO ki = 1 , 4
         INCx = incxs(ki)
         INCy = incys(ki)
         mx = ABS(INCx)
         my = ABS(INCy)
!
         DO kn = 1 , 4
            N = ns(kn)
            ksize = MIN(2,kn)
            lenx = lens(kn,mx)
            leny = lens(kn,my)
!
            IF ( ICAse==4 ) THEN
!              .. SROT ..
               DO i = 1 , 7
                  sx(i) = dx1(i)
                  sy(i) = dy1(i)
                  stx(i) = dt9x(i,kn,ki)
                  sty(i) = dt9y(i,kn,ki)
               ENDDO
               CALL SROT(N,sx,INCx,sy,INCy,sc,ss)
               CALL STEST(lenx,sx,stx,ssize2(1,ksize),Sfac)
               CALL STEST(leny,sy,sty,ssize2(1,ksize),Sfac)
            ELSE
               WRITE (NOUT,*) ' Shouldn''t be here in CHECK3'
               STOP
            ENDIF
         ENDDO
      ENDDO
!
      mwpc(1) = 1
      DO i = 2 , 11
         mwpc(i) = 0
      ENDDO
      mwps(1) = 0
      DO i = 2 , 6
         mwps(i) = 1
      ENDDO
      DO i = 7 , 11
         mwps(i) = -1
      ENDDO
      mwpinx(1) = 1
      mwpinx(2) = 1
      mwpinx(3) = 1
      mwpinx(4) = -1
      mwpinx(5) = 1
      mwpinx(6) = -1
      mwpinx(7) = 1
      mwpinx(8) = 1
      mwpinx(9) = -1
      mwpinx(10) = 1
      mwpinx(11) = -1
      mwpiny(1) = 1
      mwpiny(2) = 1
      mwpiny(3) = -1
      mwpiny(4) = -1
      mwpiny(5) = 2
      mwpiny(6) = 1
      mwpiny(7) = 1
      mwpiny(8) = -1
      mwpiny(9) = -1
      mwpiny(10) = 2
      mwpiny(11) = 1
      DO i = 1 , 11
         mwpn(i) = 5
      ENDDO
      mwpn(5) = 3
      mwpn(10) = 3
      DO i = 1 , 5
         mwpx(i) = i
         mwpy(i) = i
         mwptx(1,i) = i
         mwpty(1,i) = i
         mwptx(2,i) = i
         mwpty(2,i) = -i
         mwptx(3,i) = 6 - i
         mwpty(3,i) = i - 6
         mwptx(4,i) = i
         mwpty(4,i) = -i
         mwptx(6,i) = 6 - i
         mwpty(6,i) = i - 6
         mwptx(7,i) = -i
         mwpty(7,i) = i
         mwptx(8,i) = i - 6
         mwpty(8,i) = 6 - i
         mwptx(9,i) = -i
         mwpty(9,i) = i
         mwptx(11,i) = i - 6
         mwpty(11,i) = 6 - i
      ENDDO
      mwptx(5,1) = 1
      mwptx(5,2) = 3
      mwptx(5,3) = 5
      mwptx(5,4) = 4
      mwptx(5,5) = 5
      mwpty(5,1) = -1
      mwpty(5,2) = 2
      mwpty(5,3) = -2
      mwpty(5,4) = 4
      mwpty(5,5) = -3
      mwptx(10,1) = -1
      mwptx(10,2) = -3
      mwptx(10,3) = -5
      mwptx(10,4) = 4
      mwptx(10,5) = 5
      mwpty(10,1) = 1
      mwpty(10,2) = 2
      mwpty(10,3) = 2
      mwpty(10,4) = 4
      mwpty(10,5) = 3
      DO i = 1 , 11
         INCx = mwpinx(i)
         INCy = mwpiny(i)
         DO k = 1 , 5
            copyx(k) = mwpx(k)
            copyy(k) = mwpy(k)
            mwpstx(k) = mwptx(i,k)
            mwpsty(k) = mwpty(i,k)
         ENDDO
         CALL SROT(mwpn(i),copyx,INCx,copyy,INCy,mwpc(i),mwps(i))
         CALL STEST(5,copyx,mwpstx,mwpstx,Sfac)
         CALL STEST(5,copyy,mwpsty,mwpsty,Sfac)
      ENDDO
      END SUBROUTINE CHECK3
!*==stest.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE STEST(Len,Scomp,Strue,Ssize,Sfac)
      IMPLICIT NONE
!*--STEST906
!     ********************************* STEST **************************
!
!     THIS SUBR COMPARES ARRAYS  SCOMP() AND STRUE() OF LENGTH LEN TO
!     SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
!     NEGLIGIBLE.
!
!     C. L. LAWSON, JPL, 1974 DEC 10
!
!     .. Parameters ..
      INTEGER NOUT
      REAL ZERO
      PARAMETER (NOUT=6,ZERO=0.0E0)
!     .. Scalar Arguments ..
      REAL Sfac
      INTEGER Len
!     .. Array Arguments ..
      REAL Scomp(Len) , Ssize(Len) , Strue(Len)
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , N
      LOGICAL PASs
!     .. Local Scalars ..
      REAL sd
      INTEGER i
!     .. External Functions ..
      REAL SDIFF
      EXTERNAL SDIFF
!     .. Intrinsic Functions ..
      INTRINSIC ABS
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , PASs
!     .. Executable Statements ..
!
      DO i = 1 , Len
         sd = Scomp(i) - Strue(i)
         IF ( ABS(Sfac*sd)>ABS(Ssize(i))*EPSILON(ZERO) ) THEN
!
!                             HERE    SCOMP(I) IS NOT CLOSE TO STRUE(I).
!
            IF ( PASs ) THEN
!                             PRINT FAIL MESSAGE AND HEADER.
               PASs = .FALSE.
               WRITE (NOUT,99001)
!
99001          FORMAT ('                                       FAIL')
               WRITE (NOUT,99002)
99002          FORMAT (/                                                &
     &               ' CASE  N INCX INCY  I                            '&
     &               ,                                                  &
     &        ' COMP(I)                             TRUE(I)  DIFFERENCE'&
     &        ,'     SIZE(I)',/1X)
            ENDIF
            WRITE (NOUT,99003) ICAse , N , INCx , INCy , i , Scomp(i) , &
     &                         Strue(i) , sd , Ssize(i)
99003       FORMAT (1X,I4,I3,2I5,I3,2E36.8,2E12.4)
         ENDIF
      ENDDO
      RETURN
      END SUBROUTINE STEST
!*==stest1.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE STEST1(Scomp1,Strue1,Ssize,Sfac)
      IMPLICIT NONE
!*--STEST1968
!     ************************* STEST1 *****************************
!
!     THIS IS AN INTERFACE SUBROUTINE TO ACCOMMODATE THE FORTRAN
!     REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
!     ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
!
!     C.L. LAWSON, JPL, 1978 DEC 6
!
!     .. Scalar Arguments ..
      REAL Scomp1 , Sfac , Strue1
!     .. Array Arguments ..
      REAL Ssize(*)
!     .. Local Arrays ..
      REAL scomp(1) , strue(1)
!     .. External Subroutines ..
      EXTERNAL STEST
!     .. Executable Statements ..
!
      scomp(1) = Scomp1
      strue(1) = Strue1
      CALL STEST(1,scomp,strue,Ssize,Sfac)
!
      END SUBROUTINE STEST1
!*==sdiff.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      REAL FUNCTION SDIFF(Sa,Sb)
      IMPLICIT NONE
!*--SDIFF995
!     ********************************* SDIFF **************************
!     COMPUTES DIFFERENCE OF TWO NUMBERS.  C. L. LAWSON, JPL 1974 FEB 15
!
!     .. Scalar Arguments ..
      REAL Sa , Sb
!     .. Executable Statements ..
      SDIFF = Sa - Sb
      END FUNCTION SDIFF
!*==itest1.f90  processed by SPAG 7.51RB at 17:52 on  4 Mar 2022
      SUBROUTINE ITEST1(Icomp,Itrue)
      IMPLICIT NONE
!*--ITEST11007
!     ********************************* ITEST1 *************************
!
!     THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
!     EQUALITY.
!     C. L. LAWSON, JPL, 1974 DEC 10
!
!     .. Parameters ..
      INTEGER NOUT
      PARAMETER (NOUT=6)
!     .. Scalar Arguments ..
      INTEGER Icomp , Itrue
!     .. Scalars in Common ..
      INTEGER ICAse , INCx , INCy , N
      LOGICAL PASs
!     .. Local Scalars ..
      INTEGER id
!     .. Common blocks ..
      COMMON /COMBLA/ ICAse , N , INCx , INCy , PASs
!     .. Executable Statements ..
!
      IF ( Icomp/=Itrue ) THEN
!
!                            HERE ICOMP IS NOT EQUAL TO ITRUE.
!
         IF ( PASs ) THEN
!                             PRINT FAIL MESSAGE AND HEADER.
            PASs = .FALSE.
            WRITE (NOUT,99001)
!
99001       FORMAT ('                                       FAIL')
            WRITE (NOUT,99002)
99002       FORMAT (/' CASE  N INCX INCY                               '&
     &              ,                                                   &
     &        ' COMP                                TRUE     DIFFERENCE'&
     &        ,/1X)
         ENDIF
         id = Icomp - Itrue
         WRITE (NOUT,99003) ICAse , N , INCx , INCy , Icomp , Itrue , id
99003    FORMAT (1X,I4,I3,2I5,2I36,I12)
      ENDIF
      RETURN
      END SUBROUTINE ITEST1


!-----------------------------------------------------------------------------!
! \file   example/sort.f90
!
! Copyright (c) 2019 Oak Ridge National Laboratory, UT-Battelle, LLC.
!-----------------------------------------------------------------------------!

program sort_example
  use, intrinsic :: ISO_C_BINDING
  use flc
  use flc_algorithm, only : sort, shuffle
  use flc_random, only : Engine => MersenneEngine4, normal_distribution
  use example_utils, only : write_version, read_positive_int, STDOUT
  implicit none
  integer :: arr_size
  real(c_double), dimension(:), allocatable :: x
  real(c_double), parameter :: MEAN = 1.0d0, SIGMA = 0.5d0
  type(Engine) :: rng

  ! Print version information
  call write_version()

  ! Get array size
  arr_size = read_positive_int("array size")
  allocate(x(arr_size))

  ! Fill randomly with normal distribution
  rng = Engine()
  call normal_distribution(MEAN, SIGMA, rng, x)

  ! Sort the array
  call sort(x)
  write(STDOUT, "(a, 4(f8.3,','))") "First few elements:", x(:min(4, size(x)))

  ! Rearrange it randomly
  call shuffle(rng, x)
  write(STDOUT, "(a, 4(f8.3,','))") "After shuffling:", x(:min(4, size(x)))

  call rng%release()
end program

!-----------------------------------------------------------------------------!
! end of example/sort.f90
!-----------------------------------------------------------------------------!