 SUBROUTINE IPXETAS(IDIR, IGDTNUMI, IGDTLEN, IGDTMPLI, NPTS_INPUT,  &
                    BITMAP_INPUT, DATA_INPUT, IGDTNUMO, IGDTMPLO, &
                    NPTS_OUTPUT, BITMAP_OUTPUT, DATA_OUTPUT, IRET)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! $Revision: 74917 $
!
! SUBPROGRAM:  IPXETAS    EXPAND OR CONTRACT ETA GRIDS
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
!
! ABSTRACT: THIS SUBPROGRAM TRANSFORMS BETWEEN THE STAGGERED ETA GRIDS
!           AS USED IN THE ETA MODEL AND FOR NATIVE GRID TRANSMISSION
!           AND THEIR FULL EXPANSION AS USED FOR GENERAL INTERPOLATION
!           AND GRAPHICS.  THE ETA GRIDS ARE ROTATED LATITUDE-LONGITUDE
!           GRIDS STAGGERED AS DEFINED BY THE ARAKAWA E-GRID, THAT IS
!           WITH MASS DATA POINTS ALTERNATING WITH WIND DATA POINTS.
!
! PROGRAM HISTORY LOG:
!   96-04-10  IREDELL
! 2015-07-14  GAYNO    MAKE GRIB 2 COMPLIANT.  REPLACE 4-PT
!                      INTERPOLATION WITH CALL TO IPOLATES.
!
! USAGE:    CALL IPXETAS(IDIR, IGDTNUMI, IGDTLEN, IGDTMPLI, NPTS_INPUT,  &
!                   BITMAP_INPUT, DATA_INPUT, IGDTNUMO, IGDTMPLO, &
!                   NPTS_OUTPUT, BITMAP_OUTPUT, DATA_OUTPUT, IRET)
!
!   INPUT ARGUMENT LIST:
!     IDIR         - INTEGER TRANSFORM OPTION
!                   ( 0 TO EXPAND STAGGERED FIELDS TO FULL FIELDS)
!                   (-1 TO CONTRACT FULL MASS FIELDS TO STAGGERED FIELDS)
!                   (-2 TO CONTRACT FULL WIND FIELDS TO STAGGERED FIELDS)
!     IGDTNUMI     - INTEGER GRID DEFINITION TEMPLATE NUMBER - INPUT GRID.
!                    CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                    NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.  MUST
!                    BE = 1 (FOR A ROTATED LAT/LON GRID.)
!     IGDTLEN      - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                    TEMPLATE ARRAY - SAME FOR INPUT AND OUTPUT GRIDS
!                    (=22) WHICH ARE BOTH ROTATED LAT/LON GRIDS.
!                    CORRESPONDS TO THE GFLD%IGDTLEN COMPONENT
!                    OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTMPLI     - INTEGER (IGDTLEN) GRID DEFINITION TEMPLATE ARRAY -
!                    INPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                    OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE
!                    (SECTION 3 INFO):
!                    (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): BASIC ANGLE OF INITIAL PRODUCTION DOMAIN,
!                          OCTETS 39-42
!                    (11): SUBDIVISIONS OF BASIC ANGLE, OCTETS 43-46
!                    (12): LATITUDE OF FIRST GRID POINT, OCTETS 47-50
!                    (13): LONGITUDE OF FIRST GRID POINT, OCTETS 51-54
!                    (14): RESOLUTION AND COMPONENT FLAGS, OCTET 55
!                    (15): LATITUDE OF LAST GRID POINT, OCTETS 56-59
!                    (16): LONGITUDE OF LAST GRID POINT, OCTETS 60-63
!                    (17): I-DIRECTION INCREMENT, OCTETS 64-67
!                    (18): J-DIRECTION INCREMENT, OCTETS 68-71
!                    (19): SCANNING MODE, OCTET 72
!                    (20): LATITUDE OF SOUTHERN POLE OF PROJECTION,
!                          OCTETS 73-76
!                    (21): LONGITUDE OF SOUTHERN POLE OF PROJECTION,
!                          OCTETS 77-80
!                    (22): ANGLE OF ROTATION OF PROJECTION, OCTS 81-84
!     NPTS_INPUT   - INTEGER NUMBER POINTS INPUT GRID
!     BITMAP_INPUT - LOGICAL (NPTS_INPUT) INPUT GRID BITMAP
!     DATA_INPUT   - REAL (NPTS_INPUT) INPUT GRID DATA
!     NPTS_OUTPUT  - INTEGER NUMBER POINTS OUTPUT GRID. THE J-DIMENSION
!                    OF THE INPUT AND OUTPUT GRIDS ARE THE SAME.
!                    WHEN GOING FROM A STAGGERED TO A FULL GRID THE
!                    I-DIMENSION INCREASES TO IDIM*2-1.  WHEN GOING
!                    FROM FULL TO STAGGERED THE I-DIMENSION DECREASES
!                    TO (IDIM+1)/2.
!
!   OUTPUT ARGUMENT LIST:
!     IGDTNUMO      - INTEGER GRID DEFINITION TEMPLATE NUMBER - OUTPUT GRID.
!                     CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                     NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!                     SAME AS IGDTNUMI (=1 FOR A ROTATED LAT/LON GRID).
!     IGDTMPLO      - INTEGER (IGDTLEN) GRID DEFINITION TEMPLATE ARRAY -
!                     OUTPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                     OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!                     ARRAY DEFINITIONS SAME AS "IGDTMPLI"
!     BITMAP_OUTPUT - LOGICAL (NPTS_OUTUT) OUTPUT GRID BITMAP
!     DATA_OUTPUT   - REAL (NPTS_OUTPUT) OUTPUT GRID DATA
!     IRET          - INTEGER RETURN CODE
!                     0     SUCCESSFUL TRANSFORMATION
!                     NON-0 INVALID GRID SPECS OR PROBLEM IN IPOLATES
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER,         INTENT(IN   )    :: IDIR
 INTEGER,         INTENT(IN   )    :: IGDTNUMI, IGDTLEN
 INTEGER,         INTENT(IN   )    :: IGDTMPLI(IGDTLEN)
 INTEGER,         INTENT(IN   )    :: NPTS_INPUT, NPTS_OUTPUT
 INTEGER,         INTENT(  OUT)    :: IGDTNUMO
 INTEGER,         INTENT(  OUT)    :: IGDTMPLO(IGDTLEN)
 INTEGER,         INTENT(  OUT)    :: IRET

 LOGICAL(KIND=1), INTENT(IN   )    :: BITMAP_INPUT(NPTS_INPUT)
 LOGICAL(KIND=1), INTENT(  OUT)    :: BITMAP_OUTPUT(NPTS_OUTPUT)

 REAL,            INTENT(IN   )    :: DATA_INPUT(NPTS_INPUT)
 REAL,            INTENT(  OUT)    :: DATA_OUTPUT(NPTS_OUTPUT)

 INTEGER                           :: SCAN_MODE, ISCALE, IP, IPOPT(20)
 INTEGER                           :: IBI(1), IBO(1), J, KM, NO

 REAL                              :: DLONS
 REAL, ALLOCATABLE                 :: OUTPUT_RLAT(:), OUTPUT_RLON(:)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 IRET = 0
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! ROUTINE ONLY WORKS FOR ROTATED LAT/LON GRIDS.
 IF (IGDTNUMI/=1) THEN
   IRET=1
   RETURN
 ENDIF
!
 SCAN_MODE=IGDTMPLI(19)
 IF((SCAN_MODE==68.OR.SCAN_MODE==72).AND.(IDIR<-2.OR.IDIR>-1))THEN
   IGDTNUMO=IGDTNUMI
   IGDTMPLO=IGDTMPLI
   IGDTMPLO(19)=64
   IGDTMPLO(8)=IGDTMPLO(8)*2-1
   IF((IGDTMPLO(8)*IGDTMPLO(9))/=NPTS_OUTPUT)THEN
     IRET=3
     RETURN
   ENDIF
   ISCALE=IGDTMPLO(10)*IGDTMPLO(11)
   IF(ISCALE==0) ISCALE=10**6
   DLONS=FLOAT(IGDTMPLO(17))/FLOAT(ISCALE)
   DLONS=DLONS*0.5
   IGDTMPLO(17)=NINT(DLONS*FLOAT(ISCALE))
 ELSEIF(SCAN_MODE==64.AND.IDIR==-1)THEN  ! FULL TO H-GRID
   IGDTNUMO=IGDTNUMI
   IGDTMPLO=IGDTMPLI
   IGDTMPLO(19)=68
   IGDTMPLO(8)=(IGDTMPLO(8)+1)/2
   IF((IGDTMPLO(8)*IGDTMPLO(9))/=NPTS_OUTPUT)THEN
     IRET=3
     RETURN
   ENDIF
   ISCALE=IGDTMPLO(10)*IGDTMPLO(11)
   IF(ISCALE==0) ISCALE=10**6
   DLONS=FLOAT(IGDTMPLO(17))/FLOAT(ISCALE)
   DLONS=DLONS*2.0
   IGDTMPLO(17)=NINT(DLONS*FLOAT(ISCALE))
 ELSEIF(SCAN_MODE==64.AND.IDIR==-2)THEN  ! FULL TO V-GRID
   IGDTNUMO=IGDTNUMI
   IGDTMPLO=IGDTMPLI
   IGDTMPLO(19)=72
   IGDTMPLO(8)=(IGDTMPLO(8)+1)/2
   IF((IGDTMPLO(8)*IGDTMPLO(9))/=NPTS_OUTPUT)THEN
     IRET=3
     RETURN
   ENDIF
   ISCALE=IGDTMPLO(10)*IGDTMPLO(11)
   IF(ISCALE==0) ISCALE=10**6
   DLONS=FLOAT(IGDTMPLO(17))/FLOAT(ISCALE)
   DLONS=DLONS*2.0
   IGDTMPLO(17)=NINT(DLONS*FLOAT(ISCALE))
 ELSE
   IRET=2
   RETURN
 ENDIF

 KM=1
 IP=0
 IPOPT=0
 IBI=1
 IBO=0

 ALLOCATE(OUTPUT_RLAT(NPTS_OUTPUT))
 ALLOCATE(OUTPUT_RLON(NPTS_OUTPUT))

 CALL IPOLATES(IP, IPOPT, IGDTNUMI, IGDTMPLI, IGDTLEN, &
               IGDTNUMO, IGDTMPLO, IGDTLEN, &
               NPTS_INPUT, NPTS_OUTPUT, KM, IBI, BITMAP_INPUT, DATA_INPUT, &
               NO, OUTPUT_RLAT, OUTPUT_RLON, IBO, BITMAP_OUTPUT, DATA_OUTPUT, IRET)

 DEALLOCATE(OUTPUT_RLAT, OUTPUT_RLON)

 IF(IRET /= 0)THEN
   PRINT*,'- PROBLEM IN IPOLATES: ', IRET
   RETURN
 ENDIF

! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! REPLACE ANY UNDEFINED POINTS ALONG THE LEFT AND RIGHT EDGES.
 DO J=1, IGDTMPLO(9)
   BITMAP_OUTPUT(J*IGDTMPLO(8))=BITMAP_OUTPUT(J*IGDTMPLO(8)-1)
   DATA_OUTPUT(J*IGDTMPLO(8))=DATA_OUTPUT(J*IGDTMPLO(8)-1)
   BITMAP_OUTPUT((J-1)*IGDTMPLO(8)+1)=BITMAP_OUTPUT((J-1)*IGDTMPLO(8)+2)
   DATA_OUTPUT((J-1)*IGDTMPLO(8)+1)=DATA_OUTPUT((J-1)*IGDTMPLO(8)+2)
 ENDDO

 RETURN
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE IPXETAS


subroutine adams

!       Adams-Bashforth scheme

use vars

implicit none

real dtdx, dtdy, dtdz, rhox, rhoy, rhoz
integer i,j,k

call t_startf ('adams_uvw')

dtdx = dtn/dx
dtdy = dtn/dy
dtdz = dtn/dz

do k=1,nzm
  rhox = rho(k)*dtdx
  rhoy = rho(k)*dtdy
  rhoz = rhow(k)*dtdz
  do j=1,ny
   do i=1,nx

     dudt(i,j,k,nc) = u(i,j,k) + dt3(na) &
              *(at*dudt(i,j,k,na)+bt*dudt(i,j,k,nb)+ct*dudt(i,j,k,nc))

     dvdt(i,j,k,nc) = v(i,j,k) + dt3(na) &
              *(at*dvdt(i,j,k,na)+bt*dvdt(i,j,k,nb)+ct*dvdt(i,j,k,nc))

     dwdt(i,j,k,nc) = w(i,j,k) + dt3(na) &
              *(at*dwdt(i,j,k,na)+bt*dwdt(i,j,k,nb)+ct*dwdt(i,j,k,nc))

     u(i,j,k) = 0.5*(u(i,j,k)+dudt(i,j,k,nc)) * rhox
     v(i,j,k) = 0.5*(v(i,j,k)+dvdt(i,j,k,nc)) * rhoy
     misc(i,j,k) = 0.5*(w(i,j,k)+dwdt(i,j,k,nc))
     w(i,j,k) = 0.5*(w(i,j,k)+dwdt(i,j,k,nc)) * rhoz

   end do
  end do
end do

call t_stopf ('adams_uvw')

end subroutine adams


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!            IMPLEMENTATION OF HEBBIAN AND ANTI-HEBBIAN PLASTICITY           !!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	SUBROUTINE plasticity_i()
	USE VARIABLES
	USE PARAMETERS
	IMPLICIT NONE
	INTEGER		::	j0,jf
!=========================== Hebbian plasticity - pop 1 ===================================!
	j0 = ne + 1				!vector starting point
	jf = ne + ni1				!vector ending point
!------------------------- finding which input neurons spiked -----------------------------!
	WHERE(spk(j0:jf))
		ypost1(j0:jf) = ypost1(j0:jf)*EXP((spkt_post1(j0:jf)-tr)/pr(173))		!update post trace
		spkt_post1(j0:jf) = tr								!update last time trace is updated
		msynw(j0:jf) = msynw(j0:jf) + pr(171)*(ypost1(j0:jf) - pr(172))			!update weights
	END WHERE
!------------------------------------------------------------------------------------------!
!--------------------------- updates when post neuron spikes ------------------------------!
	IF(spk_post) THEN
		ypre1(j0:jf) = ypre1(j0:jf)*EXP((spkt_pre1(j0:jf)-tr)/pr(173))			!update pre trace
		spkt_pre1(j0:jf) = tr								!update last time trace is updated
		msynw(j0:jf) = msynw(j0:jf) + pr(171)*ypre1(j0:jf)				!update weight
		ypost1(j0:jf) = ypost1(j0:jf)*EXP((spkt_post1(j0:jf)-tr)/pr(173)) + 1.0d0	!update post trace with spike
		spkt_post1(j0:jf) = tr								!update last time trace is updated
	END IF
!------------------------------------------------------------------------------------------!
!----------------------------- finding which input neurons spiked -------------------------!
	WHERE(spk(j0:jf))
		ypre1(j0:jf) = ypre1(j0:jf)*EXP((spkt_pre1(j0:jf)-tr)/pr(173)) + 1.0d0		!update pre trace with spike
		spkt_pre1(j0:jf) = tr								!update time of last spike for trace
	END WHERE
!------------------------------------------------------------------------------------------!
!==========================================================================================!
!======================== anti-Hebbian plasticity - pop 2 =================================!
	j0 = ne + ni1 + 1			!vector starting point
	jf = ne + ni1 + ni2			!vector ending point
!------------------------- finding which input neurons spiked -----------------------------!
	WHERE(spk(j0:jf))
		ypost2(j0:jf) = ypost2(j0:jf)*EXP((spkt_post2(j0:jf)-tr)/pr(193))		!update post trace
		spkt_post2(j0:jf) = tr								!update time of last spike for trace
		msynw(j0:jf) = msynw(j0:jf) - x(11)*(ypost2(j0:jf) - pr(192))			!update weights
	END WHERE
!------------------------------------------------------------------------------------------!
!--------------------------- updates when post neuron spikes ------------------------------!
	IF(spk_post) THEN
		ypre2(j0:jf) = ypre2(j0:jf)*EXP((spkt_pre2(j0:jf)-tr)/pr(193))			!update pre trace
		spkt_pre2(j0:jf) = tr								!update time of last spike for trace
		msynw(j0:jf) = msynw(j0:jf) - x(11)*ypre2(j0:jf)				!update weights
		ypost2(j0:jf) = ypost2(j0:jf)*EXP((spkt_post2(j0:jf)-tr)/pr(193)) + 1.0d0	!update post trace with spike
		spkt_post2(j0:jf) = tr								!update time of last trace update
	END IF
!------------------------------------------------------------------------------------------!
!----------------------------- finding which input neurons spiked -------------------------!
	WHERE(spk(j0:jf))
		ypre2(j0:jf) = ypre2(j0:jf)*EXP((spkt_pre2(j0:jf)-tr)/pr(193)) + 1.0d0		!update pre trace with spike
		spkt_pre2(j0:jf) = tr								!update time of last trace update
	END WHERE
!------------------------------------------------------------------------------------------!
!------------------------------ decaying of learning rate ---------------------------------!
	x(11) = x(11)*pr(194)
!------------------------------------------------------------------------------------------!
!==========================================================================================!
!======================== max and min values for inhibitory synapses ======================!
	j0 = ne + 1				!vector starting point
	jf = ne + ni1 + ni2			!vector ending point
	WHERE(msynw(j0:jf).GT.pr(153)) msynw(j0:jf) = pr(153)	!clip weights to max value
	WHERE(msynw(j0:jf).LT.pr(157)) msynw(j0:jf) = pr(157)	!clip weigths to min value
!==========================================================================================!
	END SUBROUTINE
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


c
c ------------------------------------------------------------------
c
       subroutine evalU(Uout,deltax,deltay,dx,dy,q,qx,qy,
     &                  qxx,qxy,qyy,i,j,kirr,mitot,mjtot,nvar)

       use amr_module

       implicit double precision (a-h,o-z)

       dimension q(nvar,mitot,mjtot)
       dimension qx(nvar,mitot,mjtot), qy(nvar,mitot,mjtot)
       dimension qxx(nvar,mitot,mjtot), qyy(nvar,mitot,mjtot)
       dimension qxy(nvar,mitot,mjtot)
       dimension Uout(nvar)

       ! this assumes ssw = 2 for now, meaning quadratic poly in each cell
       ! and linear boundary segments

       ! deltax,y is distance from centroid to edge
       ! dx,dy is mesh width

       Uout = 0.d0
       shiftxx = poly(8,1,kirr)
       shiftxy = poly(9,1,kirr)
       shiftyy = poly(10,1,kirr)

       Uout(:) = q(:,i,j) + deltax*qx(:,i,j)+ deltay*qy(:,i,j)
     &          + qxx(:,i,j)*(0.5d0*deltax**2-shiftxx)
     &          + qxy(:,i,j)*(deltax*deltay-shiftxy)
     &          + qyy(:,i,j)*(0.5d0*deltay**2-shiftyy )

      return
      end


! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
! test for div operation take quad precision

program test
  integer, parameter :: k = 16, n = 4
  real(kind = k) :: a1 = 1.197656_16
  real(kind = k) :: a2, r1, r2, r3
  real(kind = k) :: r4 = 1.1_16 / 1.2_16
  real(kind = k) :: eps_q = 1.e-33_16
  integer :: result(n), expect(n)
  expect = 1
  result = 0

  a2 = 2.181123_16
  r1 = a1 / a2
  r2 = a1 / 1.12345678_16
  r3 = 123.456789_16 / 987654.3125121651_16
  if (abs((r1 - 0.549100623852941810250957878120582757_16)/r1) <= eps_q) result(1) = 1
  if (abs((r2 - 1.06604546015557447612715462004688772_16)/r2) <= eps_q) result(2) = 1
  if (abs((r3 - 1.24999999935179103974993834375864985E-0004_16)/r3) <= eps_q) result(3) = 1
  if (abs((r4 - 0.916666666666666666666666666666666731_16)/r4) <= eps_q) result(4) = 1
  call check(result, expect, n)

end program


Program testUSSA76

Use Kinds, Only: dp
Use Isothermal_Atm, Only: T
Use Isothermal_Atm, Only: P
Use Isothermal_Atm, Only: rho

Implicit None

Integer :: j,unit
Real(dp) :: z
Real(dp) :: temp,pres,dens
Integer, Parameter :: other_alts(1:24) = (/   5000, &
                                          &  10000,&
                                          &  15000, &
                                          &  20000, &
                                          &  25000, &
                                          &  30000, &
                                          &  35000, &
                                          &  40000, &
                                          &  45000, &
                                          &  50000, &
                                          &  55000, &
                                          &  60000, &
                                          &  65000, &
                                          &  70000, &
                                          &  75000, &
                                          &  80000, &
                                          &  85000, &
                                          &  90000, &
                                          &  95000, &
                                          & 100000, &
                                          & 150000, &
                                          & 200000, &
                                          & 250000, &
                                          & 500000  /)
Real(dp), Parameter :: dZmax = 1.E-3_dp !1 meter resolution

Write(*,*)
Write(*,'(A)') 'Temperature, Pressure, & Density as a function of altitude'
Write(*,'(A9,3A14)') ' Z [km] ','   T [K]   ','   P [pa]   ',' rho [g/m^3]'
Write(*,'(A9,3A14)') '--------','-----------','------------','------------'
z = 0._dp
temp = T(z)
pres = P(z)
dens = rho(z)
Write(*,'(F9.3,3ES14.6)') z,temp,pres,dens
Open(NEWUNIT=unit,FILE='TPRho.tst',ACTION='WRITE',STATUS='REPLACE')
Write(unit,'(F9.3,3ES24.16)') z,temp,pres,dens
Do j = 1,1000*1000
    z = Real(j,dp) * dZmax
    temp = T(z)
    pres = P(z)
    dens = rho(z)
    If ( Any(j .EQ. other_alts) ) Then  !make these lines persistent
        Write(*,'(A,F9.3,3ES14.6)') ACHAR(13),z,temp,pres,dens
    Else  !otherwise overprint
        Write(*,'(A,F9.3,3ES14.6)',ADVANCE='NO') ACHAR(13),z,temp,pres,dens
    End If
    Write(unit,'(F9.3,3ES24.16)') z,temp,pres,dens
End Do
Close(unit)
Write(*,*)

End Program


! { dg-do run }
!
! PR fortran/51218
!
! Contributed by Harald Anlauf
!

module a
  implicit none
  integer :: neval = 0
contains
  subroutine inc_eval
    neval = neval + 1
  end subroutine inc_eval
end module a

module b
  use a
  implicit none
contains
  function f(x) ! Should be implicit pure
    real :: f
    real, intent(in) :: x
    f = x
  end function f

  function g(x) ! Should NOT be implicit pure
    real :: g
    real, intent(in) :: x
    call inc_eval
    g = x
  end function g
end module b

program gfcbug114a
  use a
  use b
  implicit none
  real :: x = 1, y = 1, t, u, v, w
  if (neval /= 0) call abort ()
  t = f(x)*f(y)
  if (neval /= 0) call abort ()
  u = f(x)*f(y) + f(x)*f(y)
  if (neval /= 0) call abort ()
  v = g(x)*g(y)
  if (neval /= 2) call abort ()
  w = g(x)*g(y) + g(x)*g(y)
  if (neval /= 6) call abort ()
  if (t /= 1.0 .or. u /= 2.0 .or. v /= 1.0 .or. w /= 2) call abort ()
end program gfcbug114a

! { dg-final { scan-module "b" "IMPLICIT_PURE" } }


      program DRDPSI
c>> 1996-06-19 DRDPSI Krogh  Minor change in format for C conversion.
c>> 1994-10-19 DRDPSI Krogh  Changes to use M77CON
c>> 1994-09-01 DRDPSI CLL
c>> 1994-07-21 DRDPSI WVS Original Code
c--D replaces "?": DR?PSI, ?PSI, ?PSIE
      double precision E, P, DPSI, X
      integer I, IE
      external DPSI
      print '(''          X        DPSI(X)     FLAG  EST.ABS.ERR'')'
      x = -4.5d0
      do 10 i = 1, 14
         p = dpsi(x)
         call dpsie (e, ie)
         print '(2x,2g14.8,i4,2x,g14.8)', x, p, ie, e*abs(p)
         x = x + 1.0d0
   10 continue
      stop
      end


      SUBROUTINE RK4(Y,DYDX,N,X,H,YOUT)

      PARAMETER (NMAX  = 24,
     >           BIG   = 1.00E+03,
     >           SMALL = 1.00E-03 )
      DIMENSION Y(NMAX),DYDX(NMAX),YOUT(NMAX),YT(NMAX),
     >          DYT(NMAX),DYM(NMAX)

      HH = H*0.5
      H6 = H/6.00
      XH = X + HH
	  !write(*,*) 'in rk4'
	  !write(*,*) N
      DO 11 I=1,N
         YT(I)=Y(I)+HH*DYDX(I)
11    CONTINUE
      CALL DERIVS(XH,YT,DYT,N)
      DO 12 I=1,N
         YT(I)=Y(I)+HH*DYT(I)
12    CONTINUE
      CALL DERIVS(XH,YT,DYM,N)
      DO 13 I=1,N
         YT(I) = Y(I) + H*DYM(I)
         DYM(I) = DYT(I) + DYM(I)
13    CONTINUE
      CALL DERIVS(X+H,YT,DYT,N)
      DO 14 I=1,N
         YOUT(I) = Y(I) + H6*(DYDX(I) + DYT(I) + 2.00*DYM(I))
14    CONTINUE

      RETURN
      END


#include "scalar.fpp"

!=====================================================================!
! Implements the equations of motion of a pendulum
!=====================================================================!

Module pendulum_class

! use iso_fortran_env , only : dp => real64

  use physics_class,  only : physics
  use function_class, only : abstract_function

  implicit none

  private

  public :: pendulum

  !-------------------------------------------------------------------!
  ! Type that implements pendulum equations in first order form
  !-------------------------------------------------------------------!

  type, extends(physics) :: pendulum

     ! Define constants and other parameters needed for residual and
     ! jacobian assembly here

     type(scalar) :: a = 1.0d0
     type(scalar) :: g = 10.0d0
     type(scalar) :: pi = 3.1415926535897932384626433832d0

   contains

     procedure :: mapDesignVars
     procedure :: assembleResidual
     procedure :: assembleJacobian
     procedure :: getInitialStates
     procedure :: getResidualDVSens

  end type pendulum

contains

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

  subroutine mapDesignVars(this)

    class(pendulum) :: this

    this % a = this % x(1)

  end subroutine mapDesignVars

!!$  !===================================================================!
!!$  ! Sets the design variables into the system
!!$  !===================================================================!
!!$
!!$  subroutine setDesignVars(this, x)
!!$
!!$    class(pendulum)                   :: this
!!$    real(8), intent(in), dimension(:)  :: x
!!$
!!$    ! Overwrite the values to supplied ones
!!$    if (this % num_design_vars .eq. 1) then
!!$
!!$    else if (this % num_design_vars .eq. 2) then
!!$
!!$    else if (this % num_design_vars .eq. 3) then
!!$
!!$    end if
!!$
!!$  end subroutine setDesignVars

  !-------------------------------------------------------------------!
  ! Residual assembly at each time step. This is a mandary function
  ! that the user needs to implement to use the integration
  ! scheme. This is where the differential equations are supplied to
  ! the solver.
  ! -------------------------------------------------------------------!

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

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

    res(1) = uddot(1) + this % g * sin(u(1)) / this % a

  end subroutine assembleResidual

  !-------------------------------------------------------------------!
  ! Jacobian assembly at each time step. If you don't provide the
  ! analytical jacobian, set setApproximateJacobian(.true.) into the
  ! integrator object. We use finite-difference method to approximate
  ! the Jacobian.
  !
  ! Jacobian is the matrix of partial derivatives. Each row in the
  ! Jacobian matrix arises from differntiating a single equation. Each
  ! column in the Jacobian comes from a variable in the problem. Note
  ! the NEQN should be equal to NVARS for the system to be solved.
  !
  ! Note: alpha, beta and gamma are scalars that need to be multiplied
  ! with the partial derivatives DRDQ, DRDudot and DRDuddot
  ! respectively.
  ! -------------------------------------------------------------------!

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

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

    ! Zero all entries first
    jac = 0.0d0

    !-----------------------------------------------------------------!
    ! Add dR/dQ
    !-----------------------------------------------------------------!

    jac(1,1) = jac(1,1) + alpha*(this % g * cos(u(1)) / this % a)

    !-----------------------------------------------------------------!
    ! Add dR/dQDDOT
    !-----------------------------------------------------------------!

    jac(1,1) = jac(1,1) + gamma

  end subroutine assembleJacobian

  !---------------------------------------------------------------------!
  ! Sets the initial condition for use in the integator. If first order
  ! system just set initial Q, if a second order system set initial Q
  ! and udot
  !---------------------------------------------------------------------!

  subroutine getInitialStates(this, time, u, udot)

    class(pendulum) :: this

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

    u(1) = this%pi/6.0d0
    udot(1) = 0.0d0

  end subroutine getInitialStates

!!$  !===================================================================!
!!$  ! Return the number of state variables
!!$  !===================================================================!
!!$
!!$  function getNumStateVars(this)
!!$
!!$    class(pendulum) :: this
!!$    integer          :: getNumStateVars
!!$
!!$    getNumStateVars = this % num_state_vars
!!$
!!$  end function getNumStateVars

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

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

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

    jac = 0.0d0
    jac(1,1) = -scale*(this%g*sin(u(1))/(this%a*this%a))

  end subroutine getResidualDVSens

end module pendulum_class


c fishpk36 from portlib                                  12/30/83
c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                        f i s h p a k                          *
c     *                                                               *
c     *                                                               *
c     *     a package of fortran subprograms for the solution of      *
c     *                                                               *
c     *      separable elliptic partial differential equations        *
c     *                                                               *
c     *                  (version 3.1 , october 1980)                 *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *        john adams, paul swarztrauber and roland sweet         *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the national center for atmospheric research          *
c     *                                                               *
c     *                boulder, colorado  (80307)  u.s.a.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the national science foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c
c     example showing the use of sepx4 to solve the elliptic pde
c     (x+1)**2*uxx+2*(x+1)*ux+uyy-x*u=g(x,y) on the region
c     0.le.x.le.1, 0.le.y.le.1  with specified boundary conditions
c     at y=0,1 and mixed boundary conditions of the form
c     ux(0,y)+u(0,y), ux(1,y)+u(1,y) at x=0,1.
c     the approximation is generated on a uniform 33 by 33 grid.
c     the exact solution u(x,y)=(x*y)**3+1 is used to set the
c     right hand side, boundary conditions, and compute  second and
c     fourth order discretization error
c     the exact work space length required is 1005 words.  this
c     was determined by a previous call to sepx4 and print out of
c     w(1).
c
      program tsepx4
      dimension       usol(33,33),grhs(33,33),bda(33)    ,bdb(33)    ,
     1                w(1024)
      dimension       dum(1)
      external cofx4
c
c     define arithmetic functions giving exact solution
c
      ue(s,t)=(s*t)**3+1.0
      uxe(s,t)=3.0*s**2*t**3
      uxxe(s,t)=6.0*s*t**3
      uye(s,t)=3.0*s**3*t**2
      uyye(s,t)=6.0*s**3*t
c
c     set limits on region
c
      a = 0.0
      b = 1.0
      c = 0.0
      d = 1.0
c
c     set grid size
c
      m = 32
      n = 32
      dlx = (b-a)/float(m)
      dly = (d-c)/float(n)
      nx = m+1
      ny = n+1
          do 102 i=1,nx
          x = a+float(i-1)*dlx
c
c     set specified boundary conditions at y=c,d
c
          usol(i,1) = ue(x,c)
          usol(i,ny) = ue(x,d)
          call cofx4 (x,af,bf,cf)
              do 101 j=1,ny
              y = c+float(j-1)*dly
c
c     set right hand side
c
              grhs(i,j) = af*uxxe(x,y)+bf*uxe(x,y)+cf*ue(x,y)+uyye(x,y)
  101         continue
  102     continue
c
c     set mixed boundary conditions at x=a,b
c
      alpha = 1.0
      beta = 1.0
          do 103 j=1,ny
          y = c+float(j-1)*dly
          bda(j) = uxe(a,y)+alpha*ue(a,y)
          bdb(j) = uxe(b,y)+beta*ue(b,y)
  103     continue
c
c     set boundary swithces
c
      mbdcnd = 3
      nbdcnd = 1
c
c     set first dimension of usol,grhs and work space length
c
      idmn = 33
      w(1) = 1024.
c
c     obtain second order approximation
c
      iorder = 2
      call sepx4 (iorder,a,b,m,mbdcnd,bda,alpha,bdb,beta,c,d,n,nbdcnd,
     1            dum,dum,cofx4,grhs,usol,idmn,w,pertrb,ierror)
c
c     compute second order discretization error (relative)
c     also reset specified boundaries and right hand side.
c
      err = 0.0
          do 105 i=1,nx
          x = a+float(i-1)*dlx
          usol(i,1) = ue(x,c)
          usol(i,ny) = ue(x,d)
          call cofx4 (x,af,bf,cf)
              do 104 j=1,ny
              y = c+float(j-1)*dly
              err = amax1(err,abs((usol(i,j)-ue(x,y))/ue(x,y)))
              grhs(i,j) = af*uxxe(x,y)+bf*uxe(x,y)+cf*ue(x,y)+uyye(x,y)
  104         continue
  105     continue
      err2=err
c
c     obtain fourth order approximation
c
      iorder = 4
      call sepx4 (iorder,a,b,m,mbdcnd,bda,alpha,bdb,beta,c,d,n,nbdcnd,
     1            dum,dum,cofx4,grhs,usol,idmn,w,pertrb,ierror)
c
c     compute fourth order discretization error (relative)
c
      err = 0.0
          do 107 j=1,ny
          y = c+float(j-1)*dly
              do 106 i=1,nx
              x = a+float(i-1)*dlx
              err = amax1(err,abs((usol(i,j)-ue(x,y))/ue(x,y)))
  106         continue
  107     continue
      err4=err
      iw = int(w(1)+0.5)
      print 1001,ierror,err2,err4,iw
 1001 format(1h1,20x,25hsubroutine sepx4  example ///
     120x,46hthe output from the ncar control data 7600 was //
     220x,10hierror = 0 /
     320x,48hsecond order discretization error =  1.5985e-04  /
     420x,48hfourth order discretization error =  1.85749e-06  /
     520x,33hrequired length of w array = 1024 //
     620x, 32hthe output from your computer is //
     720x, 8hierror = i2 /
     820x,36hsecond order discretization error = e12.5 /
     920x,36hfourth order discretization error = e12.5 /
     920x,29hrequired length of w array = i5)
c
      end


       subroutine qinit(meqn,mbc,mx,my,xlower,ylower,
     &                   dx,dy,q,maux,aux)
      implicit none

      integer maxmx, maxmy, meqn, mbc, mx, my, maux
      double precision xlower, ylower, dx, dy
      double precision q(meqn,1-mbc:mx+mbc, 1-mbc:my+mbc)
      double precision aux(maux,1-mbc:mx+mbc, 1-mbc:my+mbc)

      integer i,j
      double precision xc,yc

      integer init_choice
      common /initchoice_comm/ init_choice

      do j = 1-mbc,my+mbc
          do i = 1-mbc,mx+mbc
              xc = xlower + (i-0.5)*dx
              yc = ylower + (j-0.5)*dy
              if (init_choice .eq. 0) then
                  if (abs(xc-0.5) .le. 0.25
     &                    .and. abs(yc-0.5) .le. 0.25) then
                      q(1,i,j) = 1.d0
                  else
                      q(1,i,j) = 0.d0
                  endif
              elseif (init_choice .eq. 1) then
                  q(1,i,j) = 1.d0
              endif
          enddo
      enddo

      return
      end


program FFTcf
use omp_lib
use myomp
use p2grid
use head
implicit none

integer(4)::LL(3)
real(4),allocatable::pos(:,:)
real(4),allocatable::ran(:,:)
real(8),allocatable::gden(:,:,:)
real(8),allocatable::rden(:,:,:)
complex(4),allocatable::vc1(:,:,:)
complex(4),allocatable::vc2(:,:,:)

real(4)::boxinfo(2,3)

integer(4)::i,j,k,dir

integer(kind(ngal))::pid

real(8),allocatable::cf8(:,:)
real(8),allocatable::cf2d(:,:,:)
real(4)::fs
real(4)::npeff
logical(4)::debug=.false.

call omp_set_num_threads(NUM_THREADS)
LL=[L,L,L]
boxinfo(1:2,1)=[0.,box]
boxinfo(1:2,2)=[0.,box]
boxinfo(1:2,3)=[0.,box]

call memo(0)
call readdata

fs=L/box
call ompshift(pos,3,ngal,[0.,0.,0.],boxinfo)
if (flag_r) call ompshift(ran,3,nran,[0.,0.,0.],boxinfo)

call ompscale(pos,3,ngal,[fs,fs,fs])
if (flag_r) call ompscale(ran,3,nran,[fs,fs,fs])

call massassign(ngal,pos,L,gden,painter)  ! get delta_g
if (flag_r) call massassign(nran,ran,L,rden,painter)  ! get delta_r

if (flag_r) gden=gden-rden

vc1=cmplx(gden,0.0)
call fftc2c_inplace(vc1,LL)  ! get delta(k)

vc1=vc1*conjg(vc1)/float(L)**3  ! get P(\vec{k})

call ifftc2c_inplace(vc1,LL)  ! get \xi(\vec{r})

if (debug) then
write(*,*) vc1(1,1,1)
do i=2,L/2
  write(*,*) vc1(i,1,1),vc1(L+2-i,1,1)
enddo
write(*,*) vc1(L/2+1,1,1)
endif

call calcxiell(vc1,LL,cf8,rbin,outname)

if (flag_xi2d) call calcxirmu(vc1,LL,cf2d,rbin,ubin,outname2)

call memo(1)

contains

subroutine memo(command)
implicit none
integer(4)::command
if (command.eq.0) then
  write(*,*) 'memo for pos:',(float(ngal)*3)*4/1024.**3,'G'
  allocate(pos(3,ngal))
  write(*,*) 'memo for gden:',(float(L)**3)*8/1024.**3,'G'
  allocate(gden(L,L,L))
  if (flag_r) then
    write(*,*) 'memo for ran:',(float(nran)*3)*4/1024.**3,'G'
    allocate(ran(3,nran))
    write(*,*) 'memo for rden:',(float(L)**3)*8/1024.**3,'G'
    allocate(rden(L,L,L))
  endif
  write(*,*) 'memo for vc1:',(float(L)**3)*8/1024.**3,'G'
  allocate(vc1(L,L,L))
  write(*,*) 'memo for vc2:',(float(L)**3)*8/1024.**3,'G'
  allocate(vc2(L,L,L))

  allocate(cf8(9,rbin))
  if (flag_xi2d) allocate(cf2d(7,rbin,ubin))
elseif(command.eq.1) then
  deallocate(pos)
  deallocate(gden)
  if (flag_r) then
    deallocate(ran)
    deallocate(rden)
  endif
  deallocate(vc1)
  deallocate(vc2)

  deallocate(cf8)
  if (flag_xi2d) deallocate(cf2d)
endif
endsubroutine memo

subroutine readdata
implicit none
integer(4)::colmax
real(4),allocatable::line(:)
! read in galaxy
colmax=maxval(gxyz)
allocate(line(colmax))
write(*,*) 'reading: ',trim(infg)
open(31,file=infg,status='old',form='formatted')
do pid=1,nghead
  read(31,*)
enddo
do pid=1,ngal
  read(31,*) line
  pos(1:3,pid)=line(gxyz(1:3))
enddo
deallocate(line)

! read in random
if (flag_r) then
colmax=maxval(rxyz)
allocate(line(colmax))
write(*,*) 'reading: ',trim(infr)
open(31,file=infr,status='old',form='formatted')
do pid=1,nrhead
  read(31,*)
enddo
do pid=1,nran
  read(31,*) line
  ran(1:3,pid)=line(rxyz(1:3))
enddo
deallocate(line)
endif
endsubroutine readdata

subroutine calcxiell(vc,LL,cf8,rbin,filename)
implicit none
integer(4)::LL(3)
complex(4)::vc(LL(1),LL(2),LL(3))
integer(4)::rbin
character(*)::filename
real(8)::cf8(9,rbin)
real(4)::ri,rj,rk,rmode,mu
real(4)::pl0,pl2,pl4
integer(4)::bin
real(4)::dr
real(4)::rbasic
real(4)::factor

dr=(rmax-rmin)/rbin
rbasic=box/L
cf8=0.
write(*,*) 'calculating correlation function'
write(*,*) 'rmin,rmax=',rmin,rmax
write(*,*) 'rbin=',rbin
write(*,*) 'dr=',dr
!$omp parallel do default(private) shared(vc,LL,rbasic,rmin,dr,rbin) &
!$omp reduction(+:cf8) schedule(guided)
do k=1,LL(3)
  if (k.le.LL(3)/2+1) then
    rk=k-1
  else
    rk=k-1-LL(3)
  endif
  rk=rbasic*rk
  do j=1,LL(2)
    if (j.le.LL(2)/2+1) then
      rj=j-1
    else
      rj=j-1-LL(2)
    endif
    rj=rbasic*rj
    do i=1,LL(1)
      if (i.le.LL(1)/2+1) then
        ri=i-1
      else
        ri=i-1-LL(1)
      endif
      ri=rbasic*ri
      if (i.eq.1.and.j.eq.1.and.k.eq.1) cycle
      if (i.eq.LL(1)/2+1.or.j.eq.LL(2)/2+1.or.k.eq.LL(3)/2+1) then
        factor=2
      else
        factor=1
      endif
      rmode=sqrt(ri*ri+rj*rj+rk*rk)
      mu=rk/rmode
      bin=floor((rmode-rmin)/dr)+1
      if (bin.lt.1.or.bin.gt.rbin) cycle
      pl0=1.*vc(i,j,k)
      pl2=0.5*(3*mu**2-1)*vc(i,j,k)
      pl4=0.125*(35*mu**4-30*mu**2+3)*vc(i,j,k)
      cf8(1,bin)=cf8(1,bin)+rmode*factor
      cf8(2,bin)=cf8(2,bin)+rmode**2*factor
      cf8(3,bin)=cf8(3,bin)+pl0*factor
      cf8(4,bin)=cf8(4,bin)+pl0**2*factor
      cf8(5,bin)=cf8(5,bin)+pl2*factor
      cf8(6,bin)=cf8(6,bin)+pl2**2*factor
      cf8(7,bin)=cf8(7,bin)+pl4*factor
      cf8(8,bin)=cf8(8,bin)+pl4**2*factor
      cf8(9,bin)=cf8(9,bin)+1.*factor
    enddo
  enddo
enddo
!$omp end parallel do

cf8(1,:)=cf8(1,:)/cf8(9,:)
cf8(2,:)=cf8(2,:)/cf8(9,:)-cf8(1,:)**2
cf8(3,:)=cf8(3,:)/cf8(9,:)
cf8(4,:)=cf8(4,:)/cf8(9,:)-cf8(3,:)**2
cf8(5,:)=cf8(5,:)/cf8(9,:)
cf8(6,:)=cf8(6,:)/cf8(9,:)-cf8(5,:)**2
cf8(7,:)=cf8(7,:)/cf8(9,:)
cf8(8,:)=cf8(8,:)/cf8(9,:)-cf8(7,:)**2

if (usecenter) then
  do i=1,rbin
    cf8(1,i)=rmin+(i-0.5)*dr
  enddo
  cf8(2,:)=0.
endif

write(*,*) 'writing: ',trim(filename)
open(32,file=filename,form='formatted',status='replace')
do i=1,rbin
  write(32,'(9e14.6)') cf8(1:9:2,i)
  if (debug) write(*,*) real(cf8(1:9:2,i))
enddo
close(32)
endsubroutine calcxiell

subroutine calcxirmu(vc,LL,cf2d,rbin,ubin,filename)
  implicit none
  integer(4)::LL(3)
  complex(4)::vc(LL(1),LL(2),LL(3))
  integer(4)::rbin
  integer(4)::ubin
  character(*)::filename
  real(8)::cf2d(7,rbin,ubin)
  real(4)::ri,rj,rk,rmode,mu
  integer(4)::bin1,bin2
  real(4)::dr,du
  real(4)::rbasic
  real(4)::factor
  real(4)::rvalue(rbin)
  real(4)::uvalue(ubin)

  dr=(rmax-rmin)/rbin
  du=(umax-umin)/ubin
  rbasic=box/L
  cf2d=0.
  write(*,*) 'calculating 2D correlation function'
  write(*,*) 'rmin,rmax=',rmin,rmax
  write(*,*) 'rbin=',rbin
  write(*,*) 'dr=',dr
  write(*,*) 'umin,rmax=',umin,umax
  write(*,*) 'ubin=',ubin
  write(*,*) 'du=',du
  !$omp parallel do default(private) shared(vc,LL,rbasic,rmin,umin,dr,du,rbin,ubin) &
  !$omp reduction(+:cf2d) schedule(guided)
  do k=1,LL(3)
    if (k.le.LL(3)/2+1) then
      rk=k-1
    else
      rk=k-1-LL(3)
    endif
    rk=rbasic*rk
    do j=1,LL(2)
      if (j.le.LL(2)/2+1) then
        rj=j-1
      else
        rj=j-1-LL(2)
      endif
      rj=rbasic*rj
      do i=1,LL(1)
        if (i.le.LL(1)/2+1) then
          ri=i-1
        else
          ri=i-1-LL(1)
        endif
        ri=rbasic*ri
        if (i.eq.1.and.j.eq.1.and.k.eq.1) cycle
        if (i.eq.LL(1)/2+1.or.j.eq.LL(2)/2+1.or.k.eq.LL(3)/2+1) then
          factor=2
        else
          factor=1
        endif
        rmode=sqrt(ri*ri+rj*rj+rk*rk)
        mu=rk/rmode
        bin1=floor((rmode-rmin)/dr)+1
        bin2=floor((mu-umin)/du)+1
        if (bin1.lt.1.or.bin1.gt.rbin) cycle
        if (bin2.lt.1.or.bin2.gt.ubin) cycle
        cf2d(1,bin1,bin2)=cf2d(1,bin1,bin2)+rmode*factor
        cf2d(2,bin1,bin2)=cf2d(2,bin1,bin2)+rmode**2*factor
        cf2d(3,bin1,bin2)=cf2d(3,bin1,bin2)+mu*factor
        cf2d(4,bin1,bin2)=cf2d(4,bin1,bin2)+mu**2*factor
        cf2d(5,bin1,bin2)=cf2d(5,bin1,bin2)+vc(i,j,k)*factor
        cf2d(6,bin1,bin2)=cf2d(6,bin1,bin2)+vc(i,j,k)**2*factor
        cf2d(7,bin1,bin2)=cf2d(7,bin1,bin2)+1.*factor
      enddo
    enddo
  enddo
  !$omp end parallel do

  cf2d(1,:,:)=cf2d(1,:,:)/cf2d(7,:,:)
  cf2d(2,:,:)=cf2d(2,:,:)/cf2d(7,:,:)-cf2d(1,:,:)**2
  cf2d(3,:,:)=cf2d(3,:,:)/cf2d(7,:,:)
  cf2d(4,:,:)=cf2d(4,:,:)/cf2d(7,:,:)-cf2d(3,:,:)**2
  cf2d(5,:,:)=cf2d(5,:,:)/cf2d(7,:,:)
  cf2d(6,:,:)=cf2d(6,:,:)/cf2d(7,:,:)-cf2d(5,:,:)**2

  do i=1,rbin
    rvalue(i)=rmin+(i-0.5)*dr
  enddo
  do i=1,ubin
    uvalue(i)=umin+(i-0.5)*du
  enddo

  write(*,*) 'writing: ',trim(filename)
  open(32,file=filename,form='formatted',status='replace')
  do i=1,rbin
    do j=1,ubin
      write(32,'(4e14.6)') rvalue(i),uvalue(j),cf2d(5,i,j),cf2d(7,i,j)
      if (debug) write(*,*) rvalue(i),uvalue(j),real(cf2d(5,i,j)),cf2d(7,i,j)
    enddo
  enddo
  close(32)

endsubroutine calcxirmu

endprogram FFTcf

include 'mkl_dfti.f90'
include 'intel_3d_fft.f90'


c
c
c     =====================================================
      subroutine rpn2(ixy,maxm,meqn,mwaves,mbc,mx,ql,qr,
     &			auxl,auxr,wave,s,amdq,apdq)
c     =====================================================
c
c     # Riemann solver for the elasticity equations in 2d, with varying
c     # material properties rho, lambda, and mu
c
c     # Note that although there are 5 eigenvectors, one eigenvalue
c     # is always zero and so we only need to compute 4 waves.
c     #
c     # solve Riemann problems along one slice of data.
c
c     # On input, ql contains the state vector at the left edge of each cell
c     #           qr contains the state vector at the right edge of each cell
c
c     # Note that the i'th Riemann problem has left state qr(i-1,:)
c     #                                    and right state ql(i,:)
c     # From the basic clawpack routines, this routine is called with ql = qr
c
c     # This data is along a slice in the x-direction if ixy=1
c     #                            or the y-direction if ixy=2.
c
c     # Contents of ql and qr:
c     #
c     # q(:,1) = sigma^{11} if ixy=1   or   sigma^{22} if ixy=2
c     # q(:,2) = sigma^{22} if ixy=1   or   sigma^{11} if ixy=2
c     # q(:,3) = sigma^{12} = sigma^{21}
c     # q(:,4) = u          if ixy=1   or   v          if ixy=2
c     # q(:,5) = v          if ixy=1   or   u          if ixy=2
c     #
c     # auxl and auxr hold corresponding slice of the aux array:
c     # Here it is assumed that auxl=auxr gives the cell values
c     # for this slice.
c     #
c     #  auxl(i,1) = rho, density
c     #  auxl(i,2) = lambda
c     #  auxl(i,3) = mu
c     #  auxl(i,4) = cp, P-wave speed
c     #  auxl(i,5) = cs, S-wave speed
c
c
c     # On output, wave contains the waves,
c     #            s the speeds,
c     #            amdq the  left-going flux difference  A^- \Delta q
c     #            apdq the right-going flux difference  A^+ \Delta q
c
c     # Note that the waves are *not* in order of increasing lambda.
c     # Instead the 1- and 2-waves are the P-waves and the 3- and 4-waves
c     # are the S-waves.   (The 5th wave has speed zero and is not used.)
c
c
c
      implicit double precision (a-h,o-z)
c
      dimension wave(1-mbc:maxm+mbc, meqn, mwaves)
      dimension    s(1-mbc:maxm+mbc, mwaves)
      dimension   ql(1-mbc:maxm+mbc, meqn)
      dimension   qr(1-mbc:maxm+mbc, meqn)
      dimension apdq(1-mbc:maxm+mbc, meqn)
      dimension amdq(1-mbc:maxm+mbc, meqn)
      dimension auxl(1-mbc:maxm+mbc, 5)
      dimension auxr(1-mbc:maxm+mbc, 5)
c
c
c     # set ku to point to  the component of the system that corresponds
c     # to velocity in the direction of this slice, kv to the orthogonal
c     # velocity.  Similarly ksig11 and ksig22 point to normal stresses.
c     # 3rd component is always shear stress sig12.
c
c
      if (ixy.eq.1) then
         ksig11 = 1
         ksig22 = 2
         ku = 4
         kv = 5
	else
         ksig11 = 2
         ksig22 = 1
         ku = 5
         kv = 4
	endif
c
c     # note that notation for u and v reflects assumption that the
c     # Riemann problems are in the x-direction with u in the normal
c     # direciton and v in the orthogonal direcion, but with the above
c     # definitions of ku and kv the routine also works with ixy=2
c
c
c     # split the jump in q at each interface into waves
c     # The jump is split into leftgoing waves traveling at speeds -cp, -cs
c     # relative to the material properties to the left of the interface,
c     # and rightgoing waves traveling at speeds +cp, +cs
c     # relative to the material properties to the right of the interface,
c
      do 20 i = 2-mbc, mx+mbc
         dsig11 = ql(i,ksig11) - qr(i-1,ksig11)
         dsig22 = ql(i,ksig22) - qr(i-1,ksig22)
         dsig12 = ql(i,3) - qr(i-1,3)
         du = ql(i,ku) - qr(i-1,ku)
         dv = ql(i,kv) - qr(i-1,kv)

c        # material properties in cells i (on right) and i-1 (on left):

	 alamr = auxl(i,2)
         amur = auxl(i,3)
	 bulkr = alamr + 2.d0*amur
	 cpr = auxl(i,4)
	 csr = auxl(i,5)

	 alaml = auxr(i-1,2)
         amul = auxr(i-1,3)
	 bulkl = alaml + 2.d0*amul
	 cpl = auxr(i-1,4)
	 csl = auxr(i-1,5)

c        # P-wave strengths:
c
	 det = bulkl*cpr + bulkr*cpl
	 if (det.eq.0.d0) then
	    write(6,*) 'det=0 in rpn2'
	    stop
	    endif
         a1 = (cpr*dsig11 + bulkr*du) / det
         a2 = (cpl*dsig11 - bulkl*du) / det

c        # S-wave strengths:
c
	 det = amul*csr + amur*csl
	 if (det.eq.0.d0) then
c            # no s-waves
	     a3 = 0.d0
	     a4 = 0.d0
	   else
	     a3 = (csr*dsig12 + amur*dv) / det
	     a4 = (csl*dsig12 - amul*dv) / det
	   endif
c
c        # 5th wave has velocity 0 so is not computed or propagated.
c
c
c        # Compute the waves.
c
         wave(i,ksig11,1) = a1 * bulkl
         wave(i,ksig22,1) = a1 * alaml
         wave(i,3,1)  = 0.d0
         wave(i,ku,1) = a1 * cpl
         wave(i,kv,1) = 0.d0
         s(i,1) = -cpl
c
         wave(i,ksig11,2) = a2 * bulkr
         wave(i,ksig22,2) = a2 * alamr
         wave(i,3,2)  = 0.d0
         wave(i,ku,2) = -a2 * cpr
         wave(i,kv,2) = 0.d0
         s(i,2) = cpr
c
         wave(i,ksig11,3) = 0.d0
         wave(i,ksig22,3) = 0.d0
         wave(i,3,3)  = a3*amul
         wave(i,ku,3) = 0.d0
         wave(i,kv,3) = a3*csl
         s(i,3) = -csl
c
         wave(i,ksig11,4) = 0.d0
         wave(i,ksig22,4) = 0.d0
         wave(i,3,4)  = a4*amur
         wave(i,ku,4) = 0.d0
         wave(i,kv,4) = -a4*csr
         s(i,4) = csr
c
   20    continue
c
c
c
c     # compute the leftgoing and rightgoing flux differences:
c     # Note s(i,1),s(i,3) < 0   and   s(i,2),s(i,4) > 0.
c
      do 220 m=1,meqn
	 do 220 i = 2-mbc, mx+mbc
	    amdq(i,m) = s(i,1)*wave(i,m,1) + s(i,3)*wave(i,m,3)
	    apdq(i,m) = s(i,2)*wave(i,m,2) + s(i,4)*wave(i,m,4)
  220       continue
c
      return
      end


SUBROUTINE beam_gm(gm,ell)
! Used in p46
! This subroutine forms the beam geometric matrix for stability analysis.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::ell
 REAL(iwp),INTENT(OUT)::gm(:,:)
 REAL(iwp)::pt1=0.1_iwp,opt2=1.2_iwp,two=2.0_iwp,d15=15.0_iwp,d30=30.0_iwp
 gm(1,1)=opt2/ell
 gm(1,2)=pt1
 gm(2,1)=pt1
 gm(1,3)=-opt2/ell
 gm(3,1)=-opt2/ell
 gm(1,4)=pt1
 gm(4,1)=pt1
 gm(2,2)=two*ell/d15
 gm(2,3)=-pt1
 gm(3,2)=-pt1
 gm(2,4)=-ell/d30
 gm(4,2)=-ell/d30
 gm(3,3)=opt2/ell
 gm(3,4)=-pt1
 gm(4,3)=-pt1
 gm(4,4)=two*ell/d15
RETURN
END SUBROUTINE beam_gm


MODULE m_tetraWeight

   IMPLICIT NONE

   PRIVATE
   PUBLIC   :: tetraWeight

   CONTAINS

   PURE REAL FUNCTION tetraWeight(efermi,etetra,ind,vol,film)

      REAL,       INTENT(IN)     :: efermi
      REAL,       INTENT(IN)     :: etetra(:)
      INTEGER,    INTENT(IN)     :: ind
      REAL,       INTENT(IN)     :: vol
      LOGICAL,    INTENT(IN)     :: film

      IF(film) THEN
         tetraWeight = tetraWeightFilm(efermi,etetra,ind) * vol/3.0
      ELSE
         tetraWeight = tetraWeightBulk(efermi,etetra,ind) * vol/4.0
      ENDIF

   END FUNCTION tetraWeight

   PURE REAL FUNCTION tetraWeightBulk(efermi,etetra,ind)

      !-------------------------------------------------------------
      ! Returns the integration weights for a single tetrahedron
      ! at one corner for charge density integration with the
      ! given fermi efermi without the volume factor in Bulk
      !
      ! The energies at the corners etetra are ordered so that
      !     etetra(1) <= etetra(2) <= etetra(3) <= etetra(4)
      ! ind is the corner index of the kpoint we are interested in
      !-------------------------------------------------------------

      REAL,       INTENT(IN)     :: efermi
      REAL,       INTENT(IN)     :: etetra(:)
      INTEGER,    INTENT(IN)     :: ind

      REAL C1, C2, C3
      INTEGER i,j
      REAL f(4)
      REAL e(4,4)

      tetraWeightBulk = 0.0

      !Prepare differences between eigenvalues at the corners e(i,j) = ei-ej
      !This is to improve readability in the formulas
      DO i = 1, 4
         DO j = 1, 4
            e(i,j) = etetra(i) - etetra(j)
         ENDDO
      ENDDO

      IF( efermi>=etetra(4) ) THEN

         tetraWeightBulk = 1.0

      ELSE IF( efermi>=etetra(3) ) THEN

         f(1:3) = ( etetra(4)-efermi )/e(4,1:3)

         SELECT CASE(ind)
         CASE(4)
            tetraWeightBulk = 1.0 - f(1) * f(2) * f(3) * ( 4.0 - f(1) - f(2) - f(3))
         CASE DEFAULT
            tetraWeightBulk = 1.0 - f(1) * f(2) * f(3) * f(ind)
         END SELECT

      ELSE IF( efermi>=etetra(2) ) THEN

         C1     = ( efermi-etetra(1) )**2/( e(4,1)*e(3,1) )

         C2     = ( efermi-etetra(1) )*( efermi-etetra(2) )*( etetra(3)-efermi )/( e(3,1)*e(3,2)*e(4,1) )

         C3     = ( efermi-etetra(2) )**2*( etetra(4)-efermi )/( e(3,2)*e(4,1)*e(4,2) )

         SELECT CASE(ind)
         CASE(1)
            tetraWeightBulk = C1 + (C1 + C2) * (etetra(3)-efermi)/e(3,1) + &
                             (C1 + C2 + C3) * (etetra(4)-efermi)/e(4,1)
         CASE(2)
            tetraWeightBulk = C1 + C2 + C3 + (C2 + C3) * (etetra(3)-efermi)/e(3,2) + &
                              C3 * (etetra(4)-efermi)/e(4,2)
         CASE(3)
            tetraWeightBulk = (C1 + C2) * (efermi-etetra(1))/e(3,1)+&
                              (C2 + C3) * (efermi-etetra(2))/e(3,2)
         CASE(4)
            tetraWeightBulk = (C1 + C2 + C3) * (efermi-etetra(1))/e(4,1) +&
                               C3 * (efermi-etetra(2))/e(4,2)
         CASE DEFAULT
         END SELECT

      ELSE IF( efermi>=etetra(1) ) THEN

         f(2:4) = ( efermi-etetra(1) )/e(2:4,1)

         SELECT CASE(ind)
         CASE(1)
            tetraWeightBulk = f(2) * f(3) * f(4) * (4.0 - f(2) - f(3) - f(4))
         CASE DEFAULT
            tetraWeightBulk = f(2) * f(3) * f(4) * f(ind)
         END SELECT

      END IF

   END FUNCTION tetraWeightBulk

   PURE REAL FUNCTION tetraWeightFilm(efermi,etetra,ind)

      !-------------------------------------------------------------
      ! Returns the integration weights for a single tetrahedron
      ! at one corner for charge density integration with the
      ! given fermi efermi without the volume factor in Film
      !
      ! The energies at the corners etetra are ordered so that
      !     etetra(1) <= etetra(2) <= etetra(3)
      ! ind is the corner index of the kpoint we are interested in
      !-------------------------------------------------------------

      REAL,       INTENT(IN)     :: efermi
      REAL,       INTENT(IN)     :: etetra(:)
      INTEGER,    INTENT(IN)     :: ind

      REAL f(3)

      tetraWeightFilm = 0.0

      IF( efermi>etetra(3) ) THEN

         tetraWeightFilm = 1.0

      ELSE IF( efermi>=etetra(2) ) THEN

         f(1:2) = ( etetra(3)-efermi )/( etetra(3)-etetra(1:2) )

         SELECT CASE(ind)
         CASE(3)
            tetraWeightFilm = 1.0 - f(1) * f(2) * ( 3.0 - f(1) - f(2) )
         CASE DEFAULT
            tetraWeightFilm = 1.0 - f(1) * f(2) * f(ind)
         END SELECT

      ELSE IF( efermi>=etetra(1) ) THEN

         f(2:3) = ( efermi-etetra(1) )/( etetra(2:3)-etetra(1) )

         SELECT CASE(ind)
         CASE(1)
            tetraWeightFilm = f(2) * f(3) * ( 3.0 - f(2) - f(3) )
         CASE DEFAULT
            tetraWeightFilm = f(2) * f(3) * f(ind)
         END SELECT

      END IF

   END FUNCTION tetraWeightFilm

END MODULE m_tetraWeight


      SUBROUTINE ZHST01( N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK,
     $                   LWORK, RWORK, RESULT )
*
*  -- LAPACK test routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            IHI, ILO, LDA, LDH, LDQ, LWORK, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   RESULT( 2 ), RWORK( * )
      COMPLEX*16         A( LDA, * ), H( LDH, * ), Q( LDQ, * ),
     $                   WORK( LWORK )
*     ..
*
*  Purpose
*  =======
*
*  ZHST01 tests the reduction of a general matrix A to upper Hessenberg
*  form:  A = Q*H*Q'.  Two test ratios are computed;
*
*  RESULT(1) = norm( A - Q*H*Q' ) / ( norm(A) * N * EPS )
*  RESULT(2) = norm( I - Q'*Q ) / ( N * EPS )
*
*  The matrix Q is assumed to be given explicitly as it would be
*  following ZGEHRD + ZUNGHR.
*
*  In this version, ILO and IHI are not used, but they could be used
*  to save some work if this is desired.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  ILO     (input) INTEGER
*  IHI     (input) INTEGER
*          A is assumed to be upper triangular in rows and columns
*          1:ILO-1 and IHI+1:N, so Q differs from the identity only in
*          rows and columns ILO+1:IHI.
*
*  A       (input) COMPLEX*16 array, dimension (LDA,N)
*          The original n by n matrix A.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  H       (input) COMPLEX*16 array, dimension (LDH,N)
*          The upper Hessenberg matrix H from the reduction A = Q*H*Q'
*          as computed by ZGEHRD.  H is assumed to be zero below the
*          first subdiagonal.
*
*  LDH     (input) INTEGER
*          The leading dimension of the array H.  LDH >= max(1,N).
*
*  Q       (input) COMPLEX*16 array, dimension (LDQ,N)
*          The orthogonal matrix Q from the reduction A = Q*H*Q' as
*          computed by ZGEHRD + ZUNGHR.
*
*  LDQ     (input) INTEGER
*          The leading dimension of the array Q.  LDQ >= max(1,N).
*
*  WORK    (workspace) COMPLEX*16 array, dimension (LWORK)
*
*  LWORK   (input) INTEGER
*          The length of the array WORK.  LWORK >= 2*N*N.
*
*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)
*
*  RESULT  (output) DOUBLE PRECISION array, dimension (2)
*          RESULT(1) = norm( A - Q*H*Q' ) / ( norm(A) * N * EPS )
*          RESULT(2) = norm( I - Q'*Q ) / ( N * EPS )
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            LDWORK
      DOUBLE PRECISION   ANORM, EPS, OVFL, SMLNUM, UNFL, WNORM
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, ZLANGE
      EXTERNAL           DLAMCH, ZLANGE
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLABAD, ZGEMM, ZLACPY, ZUNT01
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DCMPLX, MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( N.LE.0 ) THEN
         RESULT( 1 ) = ZERO
         RESULT( 2 ) = ZERO
         RETURN
      END IF
*
      UNFL = DLAMCH( 'Safe minimum' )
      EPS = DLAMCH( 'Precision' )
      OVFL = ONE / UNFL
      CALL DLABAD( UNFL, OVFL )
      SMLNUM = UNFL*N / EPS
*
*     Test 1:  Compute norm( A - Q*H*Q' ) / ( norm(A) * N * EPS )
*
*     Copy A to WORK
*
      LDWORK = MAX( 1, N )
      CALL ZLACPY( ' ', N, N, A, LDA, WORK, LDWORK )
*
*     Compute Q*H
*
      CALL ZGEMM( 'No transpose', 'No transpose', N, N, N,
     $            DCMPLX( ONE ), Q, LDQ, H, LDH, DCMPLX( ZERO ),
     $            WORK( LDWORK*N+1 ), LDWORK )
*
*     Compute A - Q*H*Q'
*
      CALL ZGEMM( 'No transpose', 'Conjugate transpose', N, N, N,
     $            DCMPLX( -ONE ), WORK( LDWORK*N+1 ), LDWORK, Q, LDQ,
     $            DCMPLX( ONE ), WORK, LDWORK )
*
      ANORM = MAX( ZLANGE( '1', N, N, A, LDA, RWORK ), UNFL )
      WNORM = ZLANGE( '1', N, N, WORK, LDWORK, RWORK )
*
*     Note that RESULT(1) cannot overflow and is bounded by 1/(N*EPS)
*
      RESULT( 1 ) = MIN( WNORM, ANORM ) / MAX( SMLNUM, ANORM*EPS ) / N
*
*     Test 2:  Compute norm( I - Q'*Q ) / ( N * EPS )
*
      CALL ZUNT01( 'Columns', N, N, Q, LDQ, WORK, LWORK, RWORK,
     $             RESULT( 2 ) )
*
      RETURN
*
*     End of ZHST01
*
      END


MODULE dfpmin_module

    !
    !   Optimize a function using gradient information using the quasi-Newton
    !   method of Broyden, Fletcher, Goldfarb, and Shanno (BFGS)
    !

    !/* external modules    */

    USE shared_constants

    IMPLICIT NONE

    !/* setup   */

    PRIVATE

    PUBLIC:: dfpmin

CONTAINS
!******************************************************************************
!******************************************************************************
SUBROUTINE dfpmin(func, dfunc, p, gtol, maxiter, stpmx, maxfun, success, message, iter)

    !/* external objects        */

    REAL(our_dble), INTENT(INOUT)   :: p(:)

    REAL(our_dble), INTENT(IN)      :: stpmx
    REAL(our_dble), INTENT(IN)      :: gtol

    INTEGER(our_int), INTENT(IN)    :: maxiter
    INTEGER(our_int), INTENT(IN)    :: maxfun
    INTEGER(our_int), INTENT(OUT)   :: iter

    LOGICAL, INTENT(OUT)            :: success

    CHARACTER(150), INTENT(OUT)     :: message

    INTERFACE

        FUNCTION func(p)

            USE shared_constants

            IMPLICIT NONE

            REAL(our_dble), INTENT(IN)  :: p(:)
            REAL(our_dble)              :: func

        END FUNCTION

        FUNCTION dfunc(p)

            USE shared_constants

            IMPLICIT NONE

            REAL(our_dble), INTENT(IN)  :: p(:)
            REAL(our_dble)              :: dfunc(SIZE(p))

        END FUNCTION

    END INTERFACE

    !/* internal objects        */

    INTEGER(our_int)                :: its
    INTEGER(our_int)                :: i

    REAL(our_dble)                  :: hessin(SIZE(p), SIZE(p))
    REAL(our_dble)                  :: pnew(SIZE(p))
    REAL(our_dble)                  :: hdg(SIZE(p))
    REAL(our_dble)                  :: xi(SIZE(p))
    REAL(our_dble)                  :: dg(SIZE(p))
    REAL(our_dble)                  :: g(SIZE(p))
    REAL(our_dble)                  :: stpmax
    REAL(our_dble)                  :: sumdg
    REAL(our_dble)                  :: sumxi
    REAL(our_dble)                  :: fret
    REAL(our_dble)                  :: den
    REAL(our_dble)                  :: fac
    REAL(our_dble)                  :: fad
    REAL(our_dble)                  :: fae
    REAL(our_dble)                  :: fp

    LOGICAL                         :: check

!------------------------------------------------------------------------------
! Algorithm
!------------------------------------------------------------------------------

    fp = func(p)
    g = dfunc(p)

    ! Initialize Hessian
    hessin = zero_dble
    DO i = 1, SIZE(p)
        hessin(i, i) = one_dble
    END DO

    xi = -g

    stpmax = stpmx * MAX(SQRT(DOT_PRODUCT(p, p)), REAL(size(p), our_dble))

    DO its = 1, maxiter

        iter = its

        CALL lnsrch(p, fp, g, xi, pnew, fret, stpmax, check, func, maxfun)

        IF (num_eval == maxfun) THEN

            success = .False.
            message = 'Maximum number of evaluations reached.'

            RETURN

        END IF

        fp = fret
        xi = pnew - p
        p = pnew

        dg = g
        g = dfunc(p)
        den = max(fret, one_dble)

        IF (MAXVAL(ABS(g) * max(ABS(p), one_dble) / den) < gtol) THEN

            success = .True.
            message = 'Gradient less than requested.'

            RETURN

        END IF

        dg =  g - dg
        hdg = matmul(hessin, dg)
        fac = DOT_PRODUCT(dg, xi)
        fae = DOT_PRODUCT(dg, hdg)
        sumdg = DOT_PRODUCT(dg, dg)
        sumxi = DOT_PRODUCT(xi, xi)

        IF (fac ** 2 > eps * sumdg * sumxi) THEN

            fac = one_dble / fac
            fad = one_dble / fae
            dg = fac * xi - fad * hdg

            hessin = hessin + fac * outerprod(xi, xi) - fad * outerprod(hdg,hdg) + fae * outerprod(dg,dg)

        END IF

        xi = -matmul(hessin,g)

    END DO

    success = .False.
    message = 'Exceeded maximum number of iterations.'

END SUBROUTINE
!******************************************************************************
!******************************************************************************
SUBROUTINE lnsrch(xold, fold, g, p, x, f, stpmax, check, func, maxfun)

    !/* external objects        */

    REAL(our_dble), INTENT(OUT)     :: x(:)
    REAL(our_dble), INTENT(OUT)     :: f

    REAL(our_dble), INTENT(IN)      :: xold(:)
    REAL(our_dble), INTENT(IN)      :: stpmax
    REAL(our_dble), INTENT(IN)      :: fold
    REAL(our_dble), INTENT(IN)      :: g(:)

    REAL(our_dble), INTENT(INOUT)   :: p(:)

    LOGICAL, INTENT(OUT)            :: check

    INTEGER(our_int), INTENT(IN)    :: maxfun

    INTERFACE

        FUNCTION func(x)

        USE shared_constants

        IMPLICIT NONE

        REAL(our_dble)              :: func

        REAL(our_dble), INTENT(IN)  :: x(:)

        END FUNCTION

    END INTERFACE

    !/* internal objects        */

    REAL(our_dble), PARAMETER       :: ALF=1.0e-4_our_dble

    INTEGER(our_int)                :: ndum

    REAL(our_dble)                  :: alamin
    REAL(our_dble)                  :: tmplam
    REAL(our_dble)                  :: slope
    REAL(our_dble)                  :: alam2
    REAL(our_dble)                  :: fold2
    REAL(our_dble)                  :: alam
    REAL(our_dble)                  :: disc
    REAL(our_dble)                  :: pabs
    REAL(our_dble)                  :: rhs1
    REAL(our_dble)                  :: rhs2
    REAL(our_dble)                  :: f2
    REAL(our_dble)                  :: a
    REAL(our_dble)                  :: b

!------------------------------------------------------------------------------
! Algorithm
!------------------------------------------------------------------------------

    ndum = size(g)

    check = .FALSE.

    pabs = SQRT(DOT_PRODUCT(p, p))

    IF (pabs > stpmax) p = p * stpmax / pabs

    slope = DOT_PRODUCT(g, p)

    alamin = eps / MAXVAL(ABS(p)/MAX(ABS(xold), one_dble))

    alam = 1.0

    DO
        x(:) = xold(:) + alam * p(:)

        f = func(x)

        IF (num_eval == maxfun) THEN
            RETURN
        END IF

        IF (alam < alamin) THEN

            x(:) = xold(:)
            check = .True.
            RETURN

        ELSEIF (f <= fold + ALF * alam * slope) THEN

            RETURN

        ELSE

            IF (alam == one_dble) THEN

                tmplam = -slope / (two_dble * (f -fold - slope))

            ELSE

                rhs1 = f - fold - alam * slope
                rhs2 = f2 - fold2 - alam2 * slope
                a = (rhs1 / alam ** 2 - rhs2 / alam2 ** 2) / (alam - alam2)
                b = (-alam2 * rhs1 / alam ** 2 + alam * rhs2 / alam2 ** 2) / (alam - alam2)

                IF (a == zero_dble) THEN

                    tmplam = -slope / (two_dble * b)

                ELSE

                    disc = b * b - three_dble * a * slope

                    IF (disc < zero_dble) THEN
                        disc = 0.001
                    END IF

                    tmplam = (-b + SQRT(disc)) / (three_dble * a)

                END IF

                IF (tmplam > half_dble * alam) tmplam = half_dble * alam

            END IF

        END IF

        alam2 = alam
        f2 = f
        fold2 = fold
        alam = MAX(tmplam, 0.1_our_dble * alam)

    END DO

END SUBROUTINE
!******************************************************************************
!******************************************************************************
PURE FUNCTION outerprod(a,b)

    !/* external objects        */

    REAL(our_dble), INTENT(IN)      :: a(:)
    REAL(our_dble), INTENT(IN)      :: b(:)

    REAL(our_dble)                  :: outerprod(SIZE(a), SIZE(b))

!------------------------------------------------------------------------------
! Algorithm
!------------------------------------------------------------------------------

    outerprod = spread(a, dim=2, ncopies=size(b)) * spread(b, dim=1, ncopies=size(a))

END FUNCTION
!******************************************************************************
!******************************************************************************
END MODULE


module unirand

  implicit none

  ! Some magic constants

  real, private, parameter :: cd = ( 7654321.0/16777216.0), &
                              cm = (16777213.0/16777216.0)

  ! The state variables

  integer, private, parameter :: nstate = 97

  real,    private, dimension(nstate) :: u
  integer, private                    :: iu, ju
  real,    private                    :: c

  ! The routines

  public  :: uni, rinit
  private :: rstart

contains

  real function uni()

    ! First call rstart(i,j,k,l), with i,j,k,l integers from 1...168 NOT all 1

    uni = u(iu) - u(ju)

    if (uni < 0.0) uni = uni + 1.0

    u(iu) = uni

    iu = iu - 1
    if (iu == 0) iu = nstate

    ju = ju - 1
    if (ju == 0) ju = nstate

    c = c - cd
    if (c < 0.0) c = c + cm

    uni = uni - c
    if (uni < 0.0) uni = uni + 1.0

  end function uni

  !
  !  The algorithm from James RMARIN to generate the 4 seeds from an
  !  integer in the range 0 <= seed <= 900,000,000
  !

  subroutine rinit(ijkl)

    integer :: ijkl, ij, kl, i, j, k, l

    ij = ijkl/30082
    kl = ijkl - 30082*ij

    i  = mod(ij/177,177) + 2
    j  = mod(ij,    177) + 2
    k  = mod(kl/169,178) + 1
    l  = mod(kl,    169)

    call rstart(i, j, k, l)

  end subroutine rinit

  subroutine rstart(i, j, k, l)

    integer :: i, j, k, l
    integer :: ii, jj, m
    real    :: s, t

    do ii = 1, nstate

       s = 0.0
       t = 0.5

       do jj = 1, 24

          m = mod(mod(i*j,179)*k,179)
          i = j
          j = k
          k = m
          l = mod(53*L+1,169)
          if (mod(l*m,64) >= 32) s = s + t
          t = 0.5*t

       end do

       u(ii) = s

    end do

    iu = nstate
    ju = 33
    c  = (362436.0/16777216.0)

  end subroutine rstart

end module unirand


!======================================================================
    SUBROUTINE define_spline
!======================================================================
!
!   initializes the values of the spline and its derivatives
!   and evaluates the spline basic arrays (elementary operators in
!   spline basis).
!
!   SUBROUTINE called:
!       gauss
!       allocate_grid
!       initvb
!       allocate_galerkin
!       initas
!
!   calling sequence:
!                        define_spline
!                   ----------------------
!                  / |          ||      ||
!                 /  |        initvb   initas
!                /   |           |     // \  \\
!           gauss    |        vbsplvd mdb mrm facsb
!                    |           ||
!       allocate_grid,galerkin vbsplvb
!
!----------------------------------------------------------------------

       USE spline_param
       USE spline_grid
       USE spline_galerkin

       IMPLICIT NONE
       REAL(8), DIMENSION(ks) :: gx, gw

       ! .. initializes variables for gaussian integration

       CALL gauss(ks, gx, gw)

       ! .. initializes the values of the spline and its derivatives

       CALL allocate_grid

       CALL initvb

       ! .. initializes the spline array (operators in spline basis)

       Call allocate_galerkin

       CALL initas

    CONTAINS

!=======================================================================
       SUBROUTINE initvb
!=======================================================================
!
!   Sets (or Initializes) the arrays
!       gr      The gaussian points for the nint intervals of [0,Rmax]
!       grm     Reciprocals of the values of gr
!               (to avoid repeated division on the CRAY)
!       grw     Gaussian weights for each of the points in gr
!       bsp     array of B-spline values at the gaussian points
!       bspd    array of values of the first and second derivative of
!               the B-splines at the gaussian points
!
!   Calling sequence:
!        initvb
!          |
!       vbsplvd
!         ||
!       vbsplvb
!
!-----------------------------------------------------------------------
!   on entry
!   --------
!       gx      the gaussian points for the interval [0,1]
!       gw      the gaussian weights for the interval [0,1]
!
!   working arrays
!   --------------
!       dbiatx  working array of dimension (ns,ks,ks) which contains the
!               values and the second derivative values of of B-spline at
!               gaussian points in the interval [0,1]
!
!-----------------------------------------------------------------------

          IMPLICIT NONE
          REAL(8), Allocatable, DIMENSION(:, :, :) :: dbiatx
          INTEGER :: m, i
          Allocate (dbiatx(nv, ks, ks)); dbiatx = 0.d0

          Do m = 1, ks
             gr(1:nv, m) = (t(1 + ks:nv + ks) - t(ks:nv + ks - 1))*gx(m) + t(ks:nv + ks - 1)
             grm(1:nv, m) = 1.d0/gr(1:nv, m)
             grw(1:nv, m) = (t(1 + ks:nv + ks) - t(ks:nv + ks - 1))*gw(m)
             Call vbsplvd(t, ks, nv, gr(1, m), 3, dbiatx)
             bsp(1:nv, m, 1:ks) = dbiatx(1:nv, 1:ks, 1)
             bspd(1:nv, m, 1:ks, 1) = dbiatx(1:nv, 1:ks, 2)
             bspd(1:nv, m, 1:ks, 2) = dbiatx(1:nv, 1:ks, 3)
             Do i = 1, ks
                bsq(1:nv, m, i) = bspd(1:nv, m, i, 1) - grm(1:nv, m)*bsp(1:nv, m, i)
             End do
          End do

          ! .. store also the values at the last knot

          call vbsplvd(t, ns, 1, t(ns + 1), 3, dbiatx)

          bsp(nv + 1, 1, 1:ks) = dbiatx(1, 1:ks, 1)
          bspd(nv + 1, 1, 1:ks, 1) = dbiatx(1, 1:ks, 2)
          bspd(nv + 1, 1, 1:ks, 2) = dbiatx(1, 1:ks, 3)
          bsq(nv + 1, 1, 1:ks) = bspd(nv + 1, 1, 1:ks, 1) - bsp(nv + 1, 1, 1:ks)/t(ns + 1)

          Deallocate (dbiatx)

       END SUBROUTINE initvb

!==================================================================
       SUBROUTINE initas
!==================================================================
!
!   Sets ( or Initializes ) the array in symmetric storage mode:
!
!       db1 --- matrix of integral <B_i,B'_j>
!       db2 --- matrix of integral <B_i,B"_j>
!       sb  --- matrix of integral <B_i,B_j>
!       bb  --- full matrix version of sb
!       r1  --- matrix of integral <B_i,r B_j>
!       rm1 --- matrix of integral <B_i,(1/r)B_j>
!       rm2 --- matrix of integral <B_i,(1/r^2)B_j>
!       rm3 --- matrix of integral <B_i,(1/r^3)B_j>
!               where i=1,..,ns, j=1,...ks
!
!   Calling sequence:
!       initas
!        /  \
!      mdb  mrm
!
!------------------------------------------------------------------

          IMPLICIT NONE

          CALL mdb1      ! .. sets db1 --- matrix of integral <B_i,B'_j>

          CALL mdb2      ! .. sets db2 --- matrix of integral <B_i,B"_j>

          CALL mrm(0, sb)              ! .. sets sb  ---  <B_i,B_j>

          CALL add_band_to_full(sb, bb) !    sets full matrix version of sb

          CALL facsb                   ! .. factorizes sb

          CALL mrm(1, r1)              ! .. sets r1  ---  <B_i,r B_j>

          CALL mrm(-1, rm1)            ! .. sets rm1 ---  <B_i,(1/r)B_j>

          CALL mrm(-2, rm2)            ! .. sets rm2 ---  <B_i,(1/r^2)B_j>

          CALL mrm(-3, rm3)            ! .. sets rm2 ---  <B_i,(1/r^3)B_j>

       END SUBROUTINE initas

!====================================================================
       SUBROUTINE mdb1
!====================================================================
!
!  Computes the matrix elements <B_i,B'_i+j-1> in the B-spline basis
!
!--------------------------------------------------------------------

          IMPLICIT NONE

          ! Local variables

          INTEGER :: i, irow, jcol, ith, jth

          db1 = 0.d0

          do ith = 1, ks
             do jth = 1, ith
                jcol = jth - ith + ks
                do i = 1, nv
                   irow = i + ith - 1
                   db1(irow, jcol) = db1(irow, jcol) &
                                     + SUM(grw(i, :)*bsp(i, :, ith)*bspd(i, :, jth, 1))
                end do
             end do
          end do

       END SUBROUTINE mdb1

!====================================================================
       SUBROUTINE mdb2
!====================================================================
!
!  Computes the matrix elements <B_i,B"_i+j-1> in the B-spline basis
!
!--------------------------------------------------------------------

          IMPLICIT NONE

          ! Local variables

          INTEGER :: i, irow, jcol, ith, jth

          db2 = 0.d0

          do ith = 1, ks
             do jth = 1, ith
                jcol = jth - ith + ks
                do i = 1, nv
                   irow = i + ith - 1
                   db2(irow, jcol) = db2(irow, jcol) &
                                     + SUM(grw(i, :)*bsp(i, :, ith)*bspd(i, :, jth, 2))
                end do
             end do
          end do

          db2(1, 1) = db2(1, 1) + SUM(grw(nv, :)*bsp(nv, :, ks - 1)*bspd(nv, :, ks, 2))

       END SUBROUTINE mdb2

    END SUBROUTINE define_spline

!====================================================================
    SUBROUTINE facsb
!====================================================================
!
!   Factorizes bs matrix which is a transpose of overlap matrix sb,
!   <B_i,B_j>,  with the correct boundary condition at r=0
!
!   SUBROUTINES called:  dpbtrf (from LAPACK)
!
!--------------------------------------------------------------------

       USE spline_param
       USE spline_grid
       USE spline_galerkin

       IMPLICIT NONE
       INTEGER :: m, ierr

       ! .. copy the array, converting to row oriented band storage mode

       bs = TRANSPOSE(sb)

       ! .. apply boundary condition at r=0

       do m = 1, ks - 1
          bs(m, ks - m + 1) = 0.d0
       end do
       bs(ks, 1) = 1.d0

       ! .. apply boundary condition at r=rmax
       bs(1:ks - 1, ns) = 0.d0
       bs(ks, ns) = 1.d0

       Call DPBTRF('U', ns, ks - 1, bs, ks, ierr)
       if (ierr .ne. 0) Stop 'facsb: dpbtrf (LAPACK) failed'

    END SUBROUTINE facsb


! This source file is part of the Limited-area GAME version (L-GAME), which is released under the MIT license.
! Github repository: https://github.com/OpenNWP/L-GAME

module multiplications

  ! This module is a collection of various multiplications of vector and/or scalar fields.

  use definitions, only: t_grid,wp
  use run_nml,     only: nlins,ncols,nlays

  implicit none

  private

  public :: scalar_times_vector_h
  public :: scalar_times_vector
  public :: scalar_times_vector_for_gradient

  contains

  subroutine scalar_times_vector_h(scalar_field,in_vector_x,in_vector_y, &
                   result_vector_x,result_vector_y)

    ! Multiplication of a scalar with a vector field at horizontal points.

    real(wp),     intent(in)    :: scalar_field(:,:,:)
    real(wp),     intent(in)    :: in_vector_x(:,:,:)
    real(wp),     intent(in)    :: in_vector_y(:,:,:)
    real(wp),     intent(inout) :: result_vector_x(:,:,:)
    real(wp),     intent(inout) :: result_vector_y(:,:,:)

    ! local variables
    integer                     :: ji,jk ! loop indices

    !$OMP PARALLEL
    !$OMP DO PRIVATE(jk)
    do jk=1,ncols+1
      result_vector_x(:,jk,:) = 0.5_wp*(scalar_field(:,jk,:) + scalar_field(:,jk+1,:))*in_vector_x(:,jk,:)
    enddo
    !$OMP END DO
    !$OMP END PARALLEL

    !$OMP PARALLEL
    !$OMP DO PRIVATE(ji)
    do ji=1,nlins+1
      result_vector_y(ji,:,:) = 0.5_wp*(scalar_field(ji,:,:) + scalar_field(ji+1,:,:))*in_vector_y(ji,:,:)
    enddo
    !$OMP END DO
    !$OMP END PARALLEL

  end subroutine scalar_times_vector_h

  subroutine scalar_times_vector_h_for_gradient(scalar_field,in_vector_x,in_vector_y, &
                   result_vector_x,result_vector_y)

    ! Multiplication of a scalar with a vector field at horizontal points.

    real(wp),     intent(in)    :: scalar_field(:,:,:)
    real(wp),     intent(in)    :: in_vector_x(:,:,:)
    real(wp),     intent(in)    :: in_vector_y(:,:,:)
    real(wp),     intent(inout) :: result_vector_x(:,:,:)
    real(wp),     intent(inout) :: result_vector_y(:,:,:)

    ! local variables
    integer                     :: ji,jk ! loop indices

    !$OMP PARALLEL
    !$OMP DO PRIVATE(jk)
    do jk=1,ncols-1
      result_vector_x(:,jk,:) = 0.5_wp*(scalar_field(2:nlins+1,jk+1,:) + scalar_field(2:nlins+1,jk+2,:))*in_vector_x(:,jk,:)
    enddo
    !$OMP END DO
    !$OMP END PARALLEL

    !$OMP PARALLEL
    !$OMP DO PRIVATE(ji)
    do ji=1,nlins-1
      result_vector_y(ji,:,:) = 0.5_wp*(scalar_field(ji+1,2:ncols+1,:) + scalar_field(ji+2,2:ncols+1,:))*in_vector_y(ji,:,:)
    enddo
    !$OMP END DO
    !$OMP END PARALLEL

  end subroutine scalar_times_vector_h_for_gradient

  subroutine scalar_times_vector_v(scalar_field,in_vector_z,result_vector_z,grid)

    ! Multiplication of an extended scalar with an inner vector field at vertical points.

    real(wp),     intent(in)    :: scalar_field(:,:,:)
    real(wp),     intent(in)    :: in_vector_z(:,:,:)
    real(wp),     intent(inout) :: result_vector_z(:,:,:)
    type(t_grid), intent(in)    :: grid

    ! local variables
    integer                     :: jl ! loop index

    !$OMP PARALLEL
    !$OMP DO PRIVATE(jl)
    do jl=2,nlays
      result_vector_z(:,:,jl) = 0.5_wp*(scalar_field(:,:,jl-1) + scalar_field(:,:,jl))*in_vector_z(:,:,jl)
    enddo
    !$OMP END DO
    !$OMP END PARALLEL
    result_vector_z(:,:,1) = 0._wp
    result_vector_z(:,:,nlays+1) = 0._wp

  end subroutine scalar_times_vector_v

  subroutine scalar_times_vector_v_for_gradient(scalar_field,in_vector_z,result_vector_z,grid)

    ! Multiplication of an extended scalar with an inner vector field at vertical points.

    real(wp),     intent(in)    :: scalar_field(:,:,:)
    real(wp),     intent(in)    :: in_vector_z(:,:,:)
    real(wp),     intent(inout) :: result_vector_z(:,:,:)
    type(t_grid), intent(in)    :: grid

    ! local variables
    integer                     :: jl ! loop index

    !$OMP PARALLEL
    !$OMP DO PRIVATE(jl)
    do jl=2,nlays
      result_vector_z(:,:,jl) = 0.5_wp*(scalar_field(2:nlins+1,2:ncols+1,jl-1) + scalar_field(2:nlins+1,2:ncols+1,jl)) &
      *in_vector_z(:,:,jl)
    enddo
    !$OMP END DO
    !$OMP END PARALLEL

  end subroutine scalar_times_vector_v_for_gradient

  subroutine scalar_times_vector(scalar_field,in_vector_x,in_vector_y,in_vector_z, &
                   result_vector_x,result_vector_y,result_vector_z,grid)

    ! Multiplication of a scalar with a vector field.

    real(wp),     intent(in)    :: scalar_field(:,:,:)
    real(wp),     intent(in)    :: in_vector_x(:,:,:)
    real(wp),     intent(in)    :: in_vector_y(:,:,:)
    real(wp),     intent(in)    :: in_vector_z(:,:,:)
    real(wp),     intent(inout) :: result_vector_x(:,:,:)
    real(wp),     intent(inout) :: result_vector_y(:,:,:)
    real(wp),     intent(inout) :: result_vector_z(:,:,:)
    type(t_grid), intent(in)    :: grid

    call scalar_times_vector_h(scalar_field,in_vector_x,in_vector_y,result_vector_x,result_vector_y)
    call scalar_times_vector_v(scalar_field,in_vector_z,result_vector_z,grid)

  end subroutine scalar_times_vector

  subroutine scalar_times_vector_for_gradient(scalar_field,in_vector_x,in_vector_y,in_vector_z, &
                   result_vector_x,result_vector_y,result_vector_z,grid)

    ! Multiplication of an extended scalar with an inner vector field.

    real(wp),     intent(in)    :: scalar_field(:,:,:)
    real(wp),     intent(in)    :: in_vector_x(:,:,:)
    real(wp),     intent(in)    :: in_vector_y(:,:,:)
    real(wp),     intent(in)    :: in_vector_z(:,:,:)
    real(wp),     intent(inout) :: result_vector_x(:,:,:)
    real(wp),     intent(inout) :: result_vector_y(:,:,:)
    real(wp),     intent(inout) :: result_vector_z(:,:,:)
    type(t_grid), intent(in)    :: grid

    call scalar_times_vector_h_for_gradient(scalar_field,in_vector_x,in_vector_y,result_vector_x,result_vector_y)
    call scalar_times_vector_v_for_gradient(scalar_field,in_vector_z,result_vector_z,grid)

  end subroutine scalar_times_vector_for_gradient

end module multiplications