SUBROUTINE generate_lattice(alpha, BR1, BR2, VOL, ORTHO, AA,BB,CC, LATTIC)
  IMPLICIT NONE
  REAL*8, intent(out)   :: VOL
  REAL*8, intent(out)   :: BR1(3,3)   ! conventional reciprocal
  REAL*8, intent(out)   :: BR2(3,3)   ! BR2(:,i) is primitive reciprocal vector b_i
  LOGICAL, intent(out)  :: ORTHO
  REAL*8, intent(in) :: alpha(3)
  REAL*8, intent(in)    :: AA, BB, CC
  CHARACTER*4, intent(in) :: LATTIC
  ! locals
  REAL*8 :: PIA(3)
  REAL*8 :: PI, SQRT3, RVFAC
  REAL*8 :: SINAB, SINBC, COSAB, COSAC, COSBC, WURZEL

  PI=ACOS(-1.0D0)
  SQRT3=SQRT(3.0D+0)
  ! It was already divided!
  !ALPHA(1)=ALPHA(1)*PI/180.0D0
  !ALPHA(2)=ALPHA(2)*PI/180.0D0
  !ALPHA(3)=ALPHA(3)*PI/180.0D0
  PIA(1)=2.d0*PI/AA
  PIA(2)=2.d0*PI/BB
  PIA(3)=2.d0*PI/CC

  SELECT CASE (LATTIC(1:1))
  CASE ('H')  !.....HEXAGONAL LATTICE
     BR1(1,1)=2.D0/SQRT3*PIA(1)
     BR1(1,2)=1.D0/SQRT3*PIA(1)
     BR1(1,3)=0.0D0
     BR1(2,1)=0.0D0
     BR1(2,2)=PIA(2)
     BR1(2,3)=0.0D0
     BR1(3,1)=0.0D0
     BR1(3,2)=0.0D0
     BR1(3,3)=PIA(3)
     !
     BR2(1,1)=2.D0/SQRT3*PIA(1)
     BR2(1,2)=1.D0/SQRT3*PIA(1)
     BR2(1,3)=0.0D0
     BR2(2,1)=0.0D0
     BR2(2,2)=PIA(2)
     BR2(2,3)=0.0D0
     BR2(3,1)=0.0D0
     BR2(3,2)=0.0D0
     BR2(3,3)=PIA(3)
     !
     RVFAC=2.D0/SQRT3
     ORTHO=.FALSE.
  CASE ('S', 'P')    !.....PRIMITIVE LATTICE
     SINBC=SIN(ALPHA(1))
     COSAB=COS(ALPHA(3))
     COSAC=COS(ALPHA(2))
     COSBC=COS(ALPHA(1))
     WURZEL=SQRT(SINBC**2-COSAC**2-COSAB**2+2*COSBC*COSAC*COSAB)
     BR2(1,1)= SINBC/WURZEL*PIA(1)
     BR2(1,2)= (-COSAB+COSBC*COSAC)/(SINBC*WURZEL)*PIA(2)
     BR2(1,3)= (COSBC*COSAB-COSAC)/(SINBC*WURZEL)*PIA(3)
     BR2(2,1)= 0.0
     BR2(2,2)= PIA(2)/SINBC
     BR2(2,3)= -PIA(3)*COSBC/SINBC
     BR2(3,1)= 0.0
     BR2(3,2)= 0.0
     BR2(3,3)= PIA(3)
     !
     BR1(1,1)= SINBC/WURZEL*PIA(1)
     BR1(1,2)= (-COSAB+COSBC*COSAC)/(SINBC*WURZEL)*PIA(2)
     BR1(1,3)= (COSBC*COSAB-COSAC)/(SINBC*WURZEL)*PIA(3)
     BR1(2,1)= 0.0
     BR1(2,2)= PIA(2)/SINBC
     BR1(2,3)= -PIA(3)*COSBC/SINBC
     BR1(3,1)= 0.0
     BR1(3,2)= 0.0
     BR1(3,3)= PIA(3)
     !
     RVFAC= 1.d0/WURZEL
     ORTHO=.TRUE.
     if(abs(alpha(1)-pi/2.d0).gt.0.0001) ortho=.false.
     if(abs(alpha(2)-pi/2.d0).gt.0.0001) ortho=.false.
     if(abs(alpha(3)-pi/2.d0).gt.0.0001) ortho=.false.
  CASE ('F')  !.....FC LATTICE
     BR1(1,1)=PIA(1)
     BR1(1,2)=0.0D0
     BR1(1,3)=0.0D0
     BR1(2,1)=0.0D0
     BR1(2,2)=PIA(2)
     BR1(2,3)=0.0D0
     BR1(3,2)=0.0D0
     BR1(3,1)=0.0D0
     BR1(3,3)=PIA(3)
     !     definitions according to column, rows convention for BR2
     BR2(1,1)=-PIA(1)
     BR2(1,2)= PIA(1)
     BR2(1,3)= PIA(1)
     BR2(2,1)= PIA(2)
     BR2(2,2)=-PIA(2)
     BR2(2,3)= PIA(2)
     BR2(3,1)= PIA(3)
     BR2(3,2)= PIA(3)
     BR2(3,3)=-PIA(3)
     !
     RVFAC=4.D0
     ORTHO=.TRUE.
  CASE ('B')  !.....BC LATTICE
     BR1(1,1)=PIA(1)
     BR1(1,2)=0.0D0
     BR1(1,3)=0.0D0
     BR1(2,1)=0.0D0
     BR1(2,2)=PIA(2)
     BR1(2,3)=0.0D0
     BR1(3,1)=0.0D0
     BR1(3,2)=0.0D0
     BR1(3,3)=PIA(3)
     !
     BR2(1,1)= 0.0D0
     BR2(1,2)= PIA(1)
     BR2(1,3)= PIA(1)
     BR2(2,1)= PIA(2)
     BR2(2,2)= 0.0D0
     BR2(2,3)= PIA(2)
     BR2(3,1)= PIA(3)
     BR2(3,2)= PIA(3)
     BR2(3,3)= 0.0D0
     !
     RVFAC=2.D0
     ORTHO=.TRUE.
  CASE ('R')   !.....RHOMBOHEDRAL LATTICE
     BR1(1,1)=1.D0/SQRT3*PIA(1)
     BR1(1,2)=1.D0/SQRT3*PIA(1)
     BR1(1,3)=-2.d0/SQRT3*PIA(1)
     BR1(2,1)=-1.0d0*PIA(2)
     BR1(2,2)=1.0d0*PIA(2)
     BR1(2,3)=0.0d0*PIA(2)
     BR1(3,1)=1.0d0*PIA(3)
     BR1(3,2)=1.0d0*PIA(3)
     BR1(3,3)=1.0d0*PIA(3)
     !
     BR2(1,1)=1.D0/SQRT3*PIA(1)
     BR2(1,2)=1.D0/SQRT3*PIA(1)
     BR2(1,3)=-2.d0/SQRT3*PIA(1)
     BR2(2,1)=-1.0d0*PIA(2)
     BR2(2,2)=1.0d0*PIA(2)
     BR2(2,3)=0.0d0*PIA(2)
     BR2(3,1)=1.0d0*PIA(3)
     BR2(3,2)=1.0d0*PIA(3)
     BR2(3,3)=1.0d0*PIA(3)
     RVFAC=6.D0/SQRT3
     ORTHO=.FALSE.
  CASE ('C')
     IF(LATTIC(2:3).EQ.'XY') then !.....CXY ORTHOROMBIC CASE
        BR1(1,1)=PIA(1)
        BR1(1,2)=0.0D0
        BR1(1,3)=0.0D0
        BR1(2,1)=0.0D0
        BR1(2,2)=PIA(2)
        BR1(2,3)=0.0D0
        BR1(3,1)=0.0D0
        BR1(3,2)=0.0D0
        BR1(3,3)=PIA(3)
        !
        BR2(1,1)= PIA(1)
        BR2(1,2)= PIA(1)
        BR2(1,3)= 0.0D0
        BR2(2,1)=-PIA(2)
        BR2(2,2)= PIA(2)
        BR2(2,3)= 0.0D0
        BR2(3,1)= 0.0D0
        BR2(3,2)= 0.0D0
        BR2(3,3)= PIA(3)
        !
        RVFAC=2.D0
        ORTHO=.TRUE.
     ELSE IF(LATTIC(2:3).EQ.'YZ') then !.....CYZ ORTHOROMBIC
        BR1(1,1)=PIA(1)
        BR1(1,2)=0.0D0
        BR1(1,3)=0.0D0
        BR1(2,1)=0.0D0
        BR1(2,2)=PIA(2)
        BR1(2,3)=0.0D0
        BR1(3,1)=0.0D0
        BR1(3,2)=0.0D0
        BR1(3,3)=PIA(3)
        !
        BR2(1,1)= PIA(1)
        BR2(1,2)= 0.0
        BR2(1,3)= 0.0
        BR2(2,1)= 0.0
        BR2(2,2)= PIA(2)
        BR2(2,3)= PIA(2)
        BR2(3,1)= 0.0
        BR2(3,2)=-PIA(3)
        BR2(3,3)= PIA(3)
        !
        RVFAC=2.0
        ORTHO=.TRUE.
     ELSE IF(LATTIC(2:3).EQ.'XZ') then !.....CXZ ORTHOROMBIC OR MONOCLINIC CASE
        IF(ABS(ALPHA(3)-PI/2.0D0).LT.0.0001) then ! ORTHOROMBIC
           BR1(1,1)=PIA(1)
           BR1(1,2)=0.0D0
           BR1(1,3)=0.0D0
           BR1(2,1)=0.0D0
           BR1(2,2)=PIA(2)
           BR1(2,3)=0.0D0
           BR1(3,1)=0.0D0
           BR1(3,2)=0.0D0
           BR1(3,3)=PIA(3)
           !
           BR2(1,1)= PIA(1)
           BR2(1,2)= 0.0
           BR2(1,3)= PIA(1)
           BR2(2,1)= 0.0
           BR2(2,2)= PIA(2)
           BR2(2,3)= 0.0
           BR2(3,1)=-PIA(3)
           BR2(3,2)= 0.0
           BR2(3,3)= PIA(3)
           !
           RVFAC=2.0
           ORTHO=.TRUE.
        ELSE                     !.....CXZ MONOCLINIC CASE
           !         write(*,*) '  gamma not equal 90'
           SINAB=SIN(ALPHA(3))
           COSAB=COS(ALPHA(3))
           !
           BR1(1,1)= PIA(1)/SINAB
           BR1(1,2)= -PIA(2)*COSAB/SINAB
           BR1(1,3)= 0.0
           BR1(2,1)= 0.0
           BR1(2,2)= PIA(2)
           BR1(2,3)= 0.0
           BR1(3,1)= 0.0
           BR1(3,2)= 0.0
           BR1(3,3)= PIA(3)
           !
           BR2(1,1)= PIA(1)/SINAB
           BR2(1,2)= -PIA(2)*COSAB/SINAB
           BR2(1,3)= PIA(1)/SINAB
           BR2(2,1)= 0.0
           BR2(2,2)= PIA(2)
           BR2(2,3)= 0.0
           BR2(3,1)=-PIA(3)
           BR2(3,2)= 0.0
           BR2(3,3)= PIA(3)
           !
           RVFAC=2.0/SINAB
           ORTHO=.FALSE.
        ENDIF
     ELSE
        GOTO 900 !  ERROR: stop the program : wrong lattice
     ENDIF
  CASE DEFAULT
     !
     GOTO 900  !  ERROR: stop the program : wrong lattice
  END SELECT

  VOL=AA*BB*CC/RVFAC

  !print *, 'PIA=', PIA
  !print *, 'ALPHA=', ALPHA
  !print *, 'lattic=', lattic
  !WRITE(6,*) 'BR1='
  !WRITE(6,'(3F12.6)'), BR1
  !WRITE(6,*) 'BR2='
  !WRITE(6,'(3F12.6)'), BR2
  !print *, 'VOL=', VOL
  RETURN

900 CONTINUE
  WRITE(6,*) 'Error in generate_lattice : wrong lattice.'
  FLUSH(6)
  STOP 'LATGEN - Error'
end SUBROUTINE generate_lattice

SUBROUTINE direct_lattice(brnn, NAT,alpha, lattic)
  IMPLICIT NONE
  DOUBLE PRECISION, intent(out) :: BRnn(3,3)
  INTEGER,          intent(in)  :: NAT
  DOUBLE PRECISION, intent(in)  :: ALPHA(3)
  CHARACTER*4,      intent(in)  :: lattic
  ! locals
  DOUBLE PRECISION :: PI, GAMMA, BETA, ALPH, COSG1, GAMMA1, SINAB, COSAB, SQRT3
  !-----------------------------------------------------------------------
  !
  PI=ACOS(-1.0D0)
  SQRT3=SQRT(3.0D+0)

  gamma=alpha(3)
  beta=alpha(2)
  alph=alpha(1)

  cosg1=(cos(gamma)-cos(alph)*cos(beta))/sin(alph)/sin(beta)
  gamma1=acos(cosg1)

  SELECT CASE (LATTIC(1:1))
  CASE ('H') !.....HEXAGONAL CASE
     BRnn(1,1)=SQRT3/2.0d0
     BRnn(1,2)=-0.5d0
     BRnn(1,3)= 0.0d0
     BRnn(2,1)= 0.0d0
     BRnn(2,2)= 1.0d0
     BRnn(2,3)= 0.0d0
     BRnn(3,1)= 0.0d0
     BRnn(3,2)= 0.0d0
     BRnn(3,3)= 1.d0
  CASE ('S', 'P')  !.....PRIMITIVE LATTICE CASE
     BRnn(1,1)=1.0d0*sin(gamma1)*sin(beta)
     BRnn(1,2)=1.0d0*cos(gamma1)*sin(beta)
     BRnn(1,3)=1.0d0*cos(beta)
     BRnn(2,1)=0.0d0
     BRnn(2,2)=1.0d0*sin(alph)
     BRnn(2,3)=1.0d0*cos(alph)
     BRnn(3,1)=0.0d0
     BRnn(3,2)=0.0d0
     BRnn(3,3)=1.0d0
  CASE ('F') !.....FC CASE (DIRECT LATTICE)
     BRnn(1,1)=0.0d0
     BRnn(1,2)=0.5d0
     BRnn(1,3)=0.5d0
     BRnn(2,1)=0.5d0
     BRnn(2,2)=0.0d0
     BRnn(2,3)=0.5d0
     BRnn(3,1)=0.5d0
     BRnn(3,2)=0.5d0
     BRnn(3,3)=0.0d0
  CASE ('B') !.....BC CASE (DIRECT LATTICE)
     BRnn(1,1)=-0.5d0
     BRnn(1,2)=0.5d0
     BRnn(1,3)=0.5d0
     BRnn(2,1)=0.5d0
     BRnn(2,2)=-0.5d0
     BRnn(2,3)=0.5d0
     BRnn(3,1)=0.5d0
     BRnn(3,2)=0.5d0
     BRnn(3,3)=-0.5d0
  CASE ('R')   !.....RHOMBOHEDRAL LATTICE
     BRnn(1,1)=1/(2.d0*SQRT3)
     BRnn(1,2)=-1/2.d0
     BRnn(1,3)=1/3.d0
     BRnn(2,1)=1/(2.d0*SQRT3)
     BRnn(2,2)=1/2.D0
     BRnn(2,3)=1/3.d0
     BRnn(3,1)=-1/SQRT3
     BRnn(3,2)=0.d0
     BRnn(3,3)=1/3.d0
  CASE ('C')
     IF(LATTIC(2:3).EQ.'XY') then      !.....CXZ ORTHOROMBIC CASE
        BRnn(1,1)=0.5d0
        BRnn(1,2)=-0.5d0
        BRnn(1,3)=0.0d0
        BRnn(2,1)=0.5d0
        BRnn(2,2)=0.5d0
        BRnn(2,3)=0.0d0
        BRnn(3,1)=0.0d0
        BRnn(3,2)=0.0d0
        BRnn(3,3)=1.0d0
     ELSE IF(LATTIC(2:3).EQ.'YZ') then  !.....CYZ ORTHOROMBIC
        BRnn(1,1)=1.0d0
        BRnn(1,2)=0.0d0
        BRnn(1,3)=0.0d0
        BRnn(2,1)=0.0d0
        BRnn(2,2)=0.5d0
        BRnn(2,3)=0.5d0
        BRnn(3,1)=0.0d0
        BRnn(3,2)=-0.5d0
        BRnn(3,3)=0.5d0
     ELSE IF(LATTIC(2:3).EQ.'XZ') then      !.....CXZ ORTHOROMBIC OR MONOCLINIC
        IF(ABS(ALPHA(3)-PI/2.0D0).LT.0.0001) then !.....CXZ ORTHOROMBIC CASE
           BRnn(1,1)=0.5d0
           BRnn(1,2)=0.0d0
           BRnn(1,3)=-0.5d0
           BRnn(2,1)=0.0d0
           BRnn(2,2)=1.0d0
           BRnn(2,3)=0.0d0
           BRnn(3,1)=0.5d0
           BRnn(3,2)=0.0d0
           BRnn(3,3)=0.5d0
        ELSE    !.....CXZ MONOCLINIC CASE
           ! write(6,*) 'gamma not equal 90'
           SINAB=SIN(ALPHA(3))
           COSAB=COS(ALPHA(3))
           BRNN(1,1)=0.5d0*sinab
           BRNN(1,2)=0.5d0*cosab
           BRNN(1,3)=-0.5d0
           BRNN(2,1)=0.0d0
           BRNN(2,2)=1.0d0
           BRNN(2,3)=0.0d0
           BRNN(3,1)=0.5d0*sinab
           BRNN(3,2)=0.5d0*cosab
           BRNN(3,3)=0.5d0
        ENDIF
     ELSE
        GOTO 900 !  ERROR: stop the program : wrong lattice
     ENDIF
  CASE DEFAULT
     GOTO 900  !  ERROR: stop the program : wrong lattice
  END SELECT
  !      write(6,*) 'Bravais Matrix:'
  !      write(6,999) brnn
  !999  format(3f15.5)
  !
  RETURN
  !        Error messages
900 CONTINUE
  WRITE(6,*) 'Error in DIRECT_LATTICE : wrong lattice.'
  FLUSH(6)
  STOP 'LATGEN - Error'
END SUBROUTINE direct_lattice


      subroutine runF_00iiiii(i1,i2,i3,i4,i5,f,Gr,Shat7,N0)
      implicit none
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      include 'pvweenumber.f'
      integer ep,N0,k,i1,i2,i3,i4,i5,np
      parameter(np=3)
      double precision f(np),Gr(np,np),den
      double complex Shat7(np,z6max,-2:0)

      do ep=-2,0
      if     ((i1 .eq. i2) .and. (i1 .eq. i3) .and. (i1 .eq. i4)
     .  .and. (i1 .eq. i5)) then
        den=12d0
        k=i1
      elseif ((i1 .eq. i2) .and. (i1 .eq. i3) .and. (i1 .eq. i4)) then
        den=10d0
        k=i1
      elseif ((i1 .eq. i2) .and. (i1 .eq. i3) .and. (i1 .eq. i5)) then
        den=10d0
        k=i1
      elseif ((i1 .eq. i2) .and. (i1 .eq. i4) .and. (i1 .eq. i5)) then
        den=10d0
        k=i1
      elseif ((i1 .eq. i3) .and. (i1 .eq. i4) .and. (i1 .eq. i5)) then
        den=10d0
        k=i1
      elseif ((i2 .eq. i3) .and. (i2 .eq. i4) .and. (i2 .eq. i5)) then
        den=10d0
        k=i2
      elseif ((i1 .eq. i2) .and. (i1 .eq. i3)) then
        den=8d0
        k=i1
      elseif ((i1 .eq. i2) .and. (i1 .eq. i4)) then
        den=8d0
        k=i1
      elseif ((i1 .eq. i2) .and. (i1 .eq. i5)) then
        den=8d0
        k=i1
      elseif ((i2 .eq. i3) .and. (i2 .eq. i4)) then
        den=8d0
        k=i2
      elseif ((i2 .eq. i3) .and. (i2 .eq. i5)) then
        den=8d0
        k=i2
      elseif ((i3 .eq. i4) .and. (i3 .eq. i5)) then
        den=8d0
        k=i3
      elseif ((i1 .eq. i2) .or. (i1 .eq. i3) .or. (i1 .eq. i4)
     .   .or. (i1 .eq. i5)) then
        den=6d0
        k=i1
      elseif ((i2 .eq. i3) .or. (i2 .eq. i4) .or. (i2 .eq. i5)) then
        den=6d0
        k=i2
      elseif ((i3 .eq. i4) .or. (i3 .eq. i5)) then
        den=6d0
        k=i3
      elseif (i4 .eq. i5) then
        den=6d0
        k=i4
      else
        den=4d0
        k=i1
      endif
      Dv(dzziiiii(z5(i1,i2,i3,i4,i5))+N0,ep)=
     . (Shat7(k,z6(k,i1,i2,i3,i4,i5),ep)
     . -f(k)*Dv(diiiiii(z6(k,i1,i2,i3,i4,i5))+N0,ep)
     . -Gr(k,1)*Dv(diiiiiii(z7(1,k,i1,i2,i3,i4,i5))+N0,ep)
     . -Gr(k,2)*Dv(diiiiiii(z7(2,k,i1,i2,i3,i4,i5))+N0,ep)
     . -Gr(k,3)*Dv(diiiiiii(z7(3,k,i1,i2,i3,i4,i5))+N0,ep))/den

      enddo

      return
      end


!
! Copyright (C) 2001-2009 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!
!-----------------------------------------------------------------------
subroutine stres_ewa (alat, nat, ntyp, ityp, zv, at, bg, tau, &
     omega, g, gg, ngm, gstart, gamma_only, gcutm, sigmaewa)
  !-----------------------------------------------------------------------
  !
  ! Ewald contribution, both real- and reciprocal-space terms are present
  !
  USE kinds
  USE constants, only : tpi, e2, eps6
  USE mp_global, ONLY : intra_pool_comm, intra_bgrp_comm
  USE mp,        ONLY : mp_sum

  implicit none
  !
  !   first the dummy variables
  !

  integer :: nat, ntyp, ityp (nat), ngm, gstart
  ! input: number of atoms in the unit cell
  ! input: number of different types of atoms
  ! input: the type of each atom
  ! input: number of plane waves for G sum
  ! input: first nonzero g vector

  logical :: gamma_only

  real(DP) :: tau (3, nat), g (3, ngm), gg (ngm), zv (ntyp), &
       at (3, 3), bg (3, 3), omega, alat, gcutm, sigmaewa (3, 3)
  ! input: the positions of the atoms in the cell
  ! input: the coordinates of G vectors
  ! input: the square moduli of G vectors
  ! input: the charge of each type of atoms
  ! input: the direct lattice vectors
  ! input: the reciprocal lattice vectors
  ! input: the volume of the unit cell
  ! input: measure of length
  ! input: cut-off of g vectors
  ! output: the ewald stress
  !
  !    here the local variables
  !
  integer, parameter :: mxr = 50
  ! the maximum number of R vectors included in r sum
  integer :: ng,  nr, na, nb, l, m, nrm
  ! counter over reciprocal G vectors
  ! counter over direct vectors
  ! counter on atoms
  ! counter on atoms
  ! counter on atoms
  ! number of R vectors included in r sum

  real(DP) :: charge, arg, tpiba2, dtau (3), alpha, r (3, mxr), &
       r2 (mxr), rmax, rr, upperbound, fact, fac, g2, g2a, sdewald, sewald
  ! total ionic charge in the cell
  ! the argument of the phase
  ! length in reciprocal space
  ! the difference tau_s - tau_s'
  ! alpha term in ewald sum
  ! input of the rgen routine ( not used here )
  ! the square modulus of R_j-tau_s-tau_s'
  ! the maximum radius to consider real space sum
  ! buffer variable
  ! used to optimize alpha
  ! auxiliary variables
  ! diagonal term
  ! nondiagonal term
  complex(DP) :: rhostar
  real(DP), external :: qe_erfc
  ! the erfc function
  !
  tpiba2 = (tpi / alat) **2
  sigmaewa(:,:) = 0.d0
  charge = 0.d0
  do na = 1, nat
     charge = charge+zv (ityp (na) )
  enddo
  !
  ! choose alpha in order to have convergence in the sum over G
  ! upperbound is a safe upper bound for the error ON THE ENERGY
  !
  alpha = 2.9d0
12 alpha = alpha - 0.1d0
  if (alpha.eq.0.0) call errore ('stres_ew', 'optimal alpha not found &
       &', 1)
  upperbound = e2 * charge**2 * sqrt (2 * alpha / tpi) * &
               qe_erfc ( sqrt (tpiba2 * gcutm / 4.0d0 / alpha) )
  if (upperbound.gt.1d-7) goto 12
  !
  ! G-space sum here
  !
  ! Determine if this processor contains G=0 and set the constant term
  !
  if (gstart == 2) then
     sdewald = tpi * e2 / 4.d0 / alpha * (charge / omega) **2
  else
     sdewald = 0.d0
  endif
  ! sdewald is the diagonal term
  if (gamma_only) then
     fact = 2.d0
  else
    fact = 1.d0
  end if
  do ng = gstart, ngm
     g2 = gg (ng) * tpiba2
     g2a = g2 / 4.d0 / alpha
     rhostar = (0.d0, 0.d0)
     do na = 1, nat
        arg = (g (1, ng) * tau (1, na) + g (2, ng) * tau (2, na) + &
               g (3, ng) * tau (3, na) ) * tpi
        rhostar = rhostar + zv (ityp (na) ) * CMPLX(cos (arg), sin (arg),kind=DP)
     enddo
     rhostar = rhostar / omega
     sewald = fact * tpi * e2 * exp ( - g2a) / g2 * abs (rhostar) **2
     sdewald = sdewald-sewald
     do l = 1, 3
        do m = 1, l
           sigmaewa (l, m) = sigmaewa (l, m) + sewald * tpiba2 * 2.d0 * &
                g (l, ng) * g (m, ng) / g2 * (g2a + 1)
        enddo
     enddo
  enddo
  do l = 1, 3
     sigmaewa (l, l) = sigmaewa (l, l) + sdewald
  enddo
  !
  ! R-space sum here (only for the processor that contains G=0)
  !
  if (gstart.eq.2) then
     rmax = 4.0d0 / sqrt (alpha) / alat
     !
     ! with this choice terms up to ZiZj*erfc(5) are counted (erfc(5)=2x10^-1
     !
     do na = 1, nat
        do nb = 1, nat
              dtau (:) = tau (:, na) - tau (:, nb)
           !
           !     generates nearest-neighbors shells r(i)=R(i)-dtau(i)
           !
           call rgen (dtau, rmax, mxr, at, bg, r, r2, nrm)
           do nr = 1, nrm
              rr = sqrt (r2 (nr) ) * alat
              fac = - e2 / 2.0d0 / omega * alat**2 * zv (ityp (na) ) * &
                   zv ( ityp (nb) ) / rr**3 * (qe_erfc (sqrt (alpha) * rr) + &
                   rr * sqrt (8 * alpha / tpi) * exp ( - alpha * rr**2) )
              do l = 1, 3
                 do m = 1, l
                    sigmaewa (l, m) = sigmaewa (l, m) + fac * r(l,nr) * r(m,nr)
                 enddo
              enddo
           enddo
        enddo
     enddo
  endif
  !
  do l = 1, 3
     do m = 1, l - 1
        sigmaewa (m, l) = sigmaewa (l, m)
     enddo

  enddo
  do l = 1, 3
     do m = 1, 3
        sigmaewa (l, m) = - sigmaewa (l, m)
     enddo
  enddo
  call mp_sum(  sigmaewa, intra_bgrp_comm )
  return
end subroutine stres_ewa


      subroutine runCF_0(m0sq,Gr,Bzero0,N0)
C---  Expression for rearrangement of Eq. 5.65
C---  Calculates C0, requires C00
C---  Small terms of order Gr(i,j)*Cij
C---  Denominator m0sq
      implicit none
      include 'TRconstants.f'
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      include 'pvweenumber.f'
      integer ep,N0,m,n,np
      parameter(np=2)
      double precision m0sq,Gr(np,np)
      double complex Bzero0(-2:0),bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gr(n,m)*Cv(cii(z2(n,m))+N0,ep)
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=4d0*Cv(cc00+N0,ep-1)

      Cv(cc0+N0,ep)=
     . (8d0*Cv(cc00+N0,ep)
     . -pole
     . -2d0*Bzero0(ep)
     . +bit)/(2d0*m0sq)

      enddo

      return
      end


!>    @brief This procedure implements the differentiated version of the
!>    @param[in] n vector length
!>    @param[in] dx vector x
!>    @param[in] g_dx derivative object associated to dx
!>    @param[in] dy vector y
!>    @param[in] g_dy derivative object associated to dy
!>    @param[in] da scalar a = alpha
!>    @param[in] incx stride in vector x
!>    @param[in] incy stride in vector y
!>    @param[out] dy vector y
!>    @param[out] g_dy derivative object associated to dy
!>    @details
!>    This procedure implements the differentiated version of the\n
!>    BLAS1 routine daxpy(). Based on original BLAS1 and changed\n
!>    to a differentiated handcoded version.\n
!>    Technique:\n
!>    Changes: use of blocking technics (bl_size=blocksize)\n
!>    Original BLAS description:\n
!>    constant times a vector plus a vector.\n
!>    uses unrolled loops for increments equal to one.\n
!>    jack dongarra, linpack, 3/11/78.\n
!>    modified 12/3/93, array(1) declarations changed to array(*)\n
      SUBROUTINE g_daxpy(n,da,dx,g_dx,incx,dy,g_dy,incy)
        DOUBLE PRECISION da, dx(*), dy(*), g_dx(*), g_dy(*)
        INTEGER incx, incy, n

!     CheCk out input:

        IF (n<=0) RETURN

!     Start of Computation :

!     Call orig. funCtion for none-differentiated Computation
        CALL daxpy(n,da,dx,incx,dy,incy)

!     for more speC. performanCe Code
        CALL daxpy(n,da,g_dx,incx,g_dy,incy)
        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

**---   O format, complex array

	parameter(N=4)
	character*22 buf(2)
	data buf /'3535353535336767676767', '1111111111122222222222'/

	complex c(2)
	integer result(N), expect(N)
	equivalence(result, c)

	read(buf,99) c
99	format(2o11)

	data expect /'35353535353'o, '36767676767'o,
     +  '11111111111'o, '22222222222'o /
	call check(result, expect, N)
	end


C     LAST UPDATE 16/03/89
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE LOGTHM
      IMPLICIT NONE
C
C Purpose: Calculate natural or base10 log of image.
C
      INCLUDE 'COMMON.FOR'
C
C Calls   8: IMDISP , WFRAME , RFRAME , OUTFIL
C            GETHDR , OPNFIL , OPNNEW , GETVAL
C Called by: BSL
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C LOCAL VARIABLES:
C
      REAL         VALUE(10)
      INTEGER      IRC,IFRAME,IHFMAX,IFRMAX,NPIX,NRAST,NFRAME,IMEM
      INTEGER      KPIC,ISPEC,LSPEC,MEM,IFFR,ILFR,INCR,IFINC,I,J,K
      INTEGER      NVAL,IBASE
      CHARACTER*80 HEAD1,HEAD2
      CHARACTER*13 HFNAM,OFNAM
C
C IRC    : Return code
C IFRAME : Total nos. of frames
C IFRMAX : Nos. of frames in sequence
C IHFMAX : Nos. of header file in sequence
C ISPEC  : First header file of sequence
C LSPEC  : Last header file in sequence
C MEM    : Positional or calibration data indicator
C IFFR   : First frame in sequence
C ILFR   : Last frame in sequence
C INCR   : Header file increment
C IFINC  : Frame increment
C HFNAM  : Header filename
C OFNAM  : Output header filename
C HEAD1  : Output header record 1
C HEAD2  : Output header record 2
C IMEM   : Output memory dataset
C NPIX   : Nos. of pixels in image
C NRAST  : Nos. of rasters in image
C NFRAME : Nos. of frames in dataset
C KPIC   : Current image nos.
C NVAL   : Nos. of values entered at terminal
C
      DATA  IMEM/1/
C
C-----------------------------------------------------------------------
10    KPIC=0
C
      CALL GETHDR (ITERM,IPRINT,IUNIT,HFNAM,ISPEC,LSPEC,INCR,MEM,IFFR,
     &             ILFR,IFINC,IHFMAX,IFRMAX,NPIX,NRAST,IRC)
      IF (IRC.NE.0) GOTO 999
      IFRAME=IHFMAX+IFRMAX-1
C
20    IBASE=1
      WRITE (IPRINT,1000)
      CALL GETVAL (ITERM,VALUE,NVAL,IRC)
      IF (IRC.EQ.1) GOTO 80
      IF (IRC.EQ.2) GOTO 20
      IF (NVAL.GT.0) IBASE=INT(VALUE(1))
C
      DO 70 I=1,IHFMAX
         CALL OPNFIL (JUNIT,HFNAM,ISPEC,MEM,IFFR,ILFR,NPIX,NRAST,
     &                NFRAME,IRC)
         IF (IRC.EQ.0) THEN
C
            ISPEC=ISPEC+INCR
            DO 60 J=1,IFRMAX
               CALL RFRAME (JUNIT,IFFR,NPIX,NRAST,SP1,IRC)
               IF (IRC.NE.0) GOTO 80
               IFFR=IFFR+IFINC
               KPIC=KPIC+1
C
               call timer ()
               IF (IBASE.EQ.1) THEN
                  DO 30 K=1,NPIX*NRAST
                     IF (SP1(K).GT.0.0) THEN
                        SP2(K)=LOG(SP1(K))
                     ELSE
                        SP2(K)=0.0
                     ENDIF
30                CONTINUE
               ELSE
                  DO 40 K=1,NPIX*NRAST
                     IF (SP1(K).GT.0.0) THEN
                        SP2(K)=LOG10(SP1(K))
                     ELSE
                        SP2(K)=0.0
                     ENDIF
40                CONTINUE
               ENDIF
               call timer ()
C
               IF (IFRAME.EQ.1) CALL IMDISP(ITERM,IPRINT,SP2,NPIX,NRAST)
               IF (KPIC.EQ.1) THEN
                  CALL OUTFIL (ITERM,IPRINT,OFNAM,HEAD1,HEAD2,IRC)
                  IF (IRC.NE.0) GOTO 80
                  CALL OPNNEW (KUNIT,NPIX,NRAST,IFRAME,OFNAM,IMEM,HEAD1,
     &                         HEAD2,IRC)
                  IF (IRC.NE.0) GOTO 80
               ENDIF
               CALL WFRAME (KUNIT,KPIC,NPIX,NRAST,SP2,IRC)
               IF (IRC.NE.0) GOTO 80
60          CONTINUE
            CALL FCLOSE (JUNIT)
         ENDIF
70    CONTINUE
80    CALL FCLOSE (KUNIT)
      CALL FCLOSE (JUNIT)
      GOTO 10
999   RETURN
C
1000  FORMAT (' Enter [1] for natural log, [2] for base10 log. [1]: ',$)
      END


      PROGRAM ARRAY1S
c
c    Since you will be pushing your real work out of the main program
c    into Subprograms, you need to know about passing arrays in and out
c    of Subroutines.  Here is a rewrite of array1.f
c
c    John Mahaffy   12/27/94
c
      IMPLICIT NONE
      INTEGER ND
      PARAMETER (ND=10)
c
      REAL A(ND),B(ND),C(ND)
      REAL CSUM,CMAX,CMIN,AVERAGE
c
      DATA  A/1.,2.,3.,4.,5.,6.,7.,8.,9.,10./,B/3*1.,4*2.,3*3./
c
C$ SMECY MAP(PE,1)
      CALL CPROPS(A,B,C,ND,AVERAGE,CMAX,CMIN)
      CALL WRITEC(C,ND,AVERAGE,CMAX,CMIN)
      STOP
      END
      SUBROUTINE CPROPS( A, B, C, N , CAVG, CMAX, CMIN)
C
C   A common practice in Fortran 77 programs is to use a * in the dimension
C   specification.  You are saying "trust me, I know what I'm doing. All
C   you need to know is that its an array"
C
      REAL A(*),B(*),C(*)
      REAL CSUM,CMAX,CMIN,CAVG
      INTEGER I,N
c
c     Begin Executable Statements
c
      CSUM=0.
      CMAX=-1.E38
      CMIN=1.E38
      DO 100 I=1,N
         C(I)=A(I)+B(I)
         CMAX=MAX(C(I),CMAX)
         CMIN=MIN(C(I),CMIN)
 100     CSUM=CSUM+C(I)
C
      CAVG=CSUM/N
      RETURN
      END
      SUBROUTINE WRITEC( C, N, CAVG, CMAX, CMIN)
C
C   A common practice in Fortran 77 programs is to use a * in the dimension
C   specification.  You are saying "trust me, I know what I'm doing. All
C   you need to know is that its an array"
C
      REAL C(*)
      REAL CMAX,CMIN,CAVG
      INTEGER J,N
C
c    The next write statement illustrates use of * for the unit number.
c    It represents the default unit, which is the terminal.
c
      WRITE(*,*) ' RESULTS FOR FULL C ARRAY'
c
c    The format associated with the following write spreads the output
c    of the three values (AVERAGE, CMIN, and CMAX) over 3 output lines.
c
      WRITE(6,2000)CAVG,CMIN,CMAX
 2000 FORMAT(' AVERAGE OF ALL ELEMENTS IN C = ', F8.3,/,
     &       ' MINIMUM OF ALL ELEMENTS IN C = ', F8.3,/,
     &       ' MAXIMUM OF ALL ELEMENTS IN C = ', F8.3)
c
      WRITE(6,2001) (C(J),J=1,N)
 2001 FORMAT(' C = ',/,(8E10.2))
C
      RETURN
      END


recursive integer function fib (n) result(res)
   use omp_lib
   implicit none

   integer, intent(in) :: n
   integer ::  x, y
   if (n < 2) then
      res = n
   else
      !$omp task shared (x)
         x = fib(n-1)
      !$omp end task
      !$omp task shared (y)
          y = fib(n-2)
      !$omp end task
      !$omp taskwait
      res = x + y
   endif
end function fib

program main
   use omp_lib
   implicit none

   interface
      function fib (n)
         integer :: fib
         integer, intent(in) :: n
      end function fib
   end interface

   integer :: NW, result
   NW = 30
   !$omp parallel
      !$omp single
          result = fib(NW)
      !$omp end single
   !$omp end parallel
   print *, "fib(",NW,")=", result
end program main


      PROGRAM TEST4
      REAL T(10),V(10)

      DO 10 I=1,10
         T(I) = 0.0
         V(I) = T(I) ** 2
 10   CONTINUE
      END


program remove_dups
  implicit none
  integer :: example(12)         ! The input
  integer :: res(size(example))  ! The output
  integer :: k                   ! The number of unique elements
  integer :: i, j

  example = [1, 2, 3, 2, 2, 4, 5, 5, 4, 6, 6, 5]
  k = 1
  res(1) = example(1)
  outer: do i=2,size(example)
     do j=1,k
        if (res(j) == example(i)) then
           ! Found a match so start looking again
           cycle outer
        end if
     end do
     ! No match found so add it to the output
     k = k + 1
     res(k) = example(i)
  end do outer
  write(*,advance='no',fmt='(a,i0,a)') 'Unique list has ',k,' elements: '
  write(*,*) res(1:k)
end program remove_dups


! { dg-do compile }
!
! PR fortran/57142
!
integer :: B(huge(1)+3_8,2_8)
integer(8) :: var1(2), var2, var3

var1 = shape(B) ! { dg-error "SHAPE overflows its kind" }
var2 = size(B) ! { dg-error "SIZE overflows its kind" }
var3 = size(B,dim=1) ! { dg-error "SIZE overflows its kind" }
end


!
! The Laboratory of Algorithms
!
! The MIT License
!
! Copyright 2011-2015 Andrey Pudov.
!
! 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.
!

module MUDepthFirstSearch

    use MDepthFirstSearch
    use MGraph
    use MUAsserts
    use MUReport

    implicit none
    private

    type, public :: TUDepthFirstSearch
    contains
        procedure, nopass :: present
    end type
contains
    subroutine present()
        type(TDepthFirstSearch) dfs
        type(TGraph)            graph

        integer, dimension(:), pointer :: sequence
        real :: start

        call graph%init()

        call graph%addVertex(1)
        call graph%addVertex(2)
        call graph%addVertex(3)
        call graph%addVertex(4)
        call graph%addVertex(5)
        call graph%addVertex(6)

        !   2 - 3 - 6
        !  /
        ! 1
        !  \
        !   4 - 5

        ! expected to have 1 - 2 - 3 - 6 - 4 - 5

        call graph%addEdge(1, 2)
        call graph%addEdge(2, 3)
        call graph%addEdge(3, 6)
        call graph%addEdge(1, 4)
        call graph%addEdge(4, 5)

        call cpu_time(start)

        sequence => dfs%search(graph)

        call report('Graph', 'DepthFirstSearch', '', start)
        call assert_equals(sequence(1:6), (/ 1, 2, 3, 6, 4, 5 /))

        call graph%destroy()
        deallocate(sequence)

        print *, ''
    end subroutine
end module


      SUBROUTINE GDSWIZ05(KGDS,IOPT,NPTS,FILL,XPTS,YPTS,RLON,RLAT,NRET,
     &                    LROT,CROT,SROT)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:  GDSWIZ05   GDS WIZARD FOR POLAR STEREOGRAPHIC AZIMUTHAL
C   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
C
C ABSTRACT: THIS SUBPROGRAM DECODES THE GRIB GRID DESCRIPTION SECTION
C           (PASSED IN INTEGER FORM AS DECODED BY SUBPROGRAM W3FI63)
C           AND RETURNS ONE OF THE FOLLOWING:
C             (IOPT=+1) EARTH COORDINATES OF SELECTED GRID COORDINATES
C             (IOPT=-1) GRID COORDINATES OF SELECTED EARTH COORDINATES
C           FOR POLAR STEREOGRAPHIC AZIMUTHAL PROJECTIONS.
C           IF THE SELECTED COORDINATES ARE MORE THAN ONE GRIDPOINT
C           BEYOND THE THE EDGES OF THE GRID DOMAIN, THEN THE RELEVANT
C           OUTPUT ELEMENTS ARE SET TO FILL VALUES.
C           THE ACTUAL NUMBER OF VALID POINTS COMPUTED IS RETURNED TOO.
C           CALCULATIONS FOR A SPHERICAL OR ELLIPTICAL EARTH
C           ARE INVOKED ACCORDING TO THE INFORMATION IN
C           SECTION 1, OCTET 17, BIT 2.  NOTE: ELLIPTICAL EARTH
C           CALCULATIONS ARE BASED ON THE WGS84 DATUM.
C
C PROGRAM HISTORY LOG:
C   1996-04-10  IREDELL
C   2006-01-10  GAYNO    CALCULATIONS FOR ELLIPTICAL EARTH.
C   2012-08-14  GAYNO    COMPUTE E AND E_OVER_2 AS EXECUTABLE
C                        STATEMENTS.  SOME COMPILERS CAN'T
C                        HANDLE INTRINSICS IN PARAMETER STMTS.
C
C USAGE:    CALL GDSWIZ05(KGDS,IOPT,NPTS,FILL,XPTS,YPTS,RLON,RLAT,NRET,
C     &                   LROT,CROT,SROT)
C
C   INPUT ARGUMENT LIST:
C     KGDS     - INTEGER (200) GDS PARAMETERS AS DECODED BY W3FI63
C     IOPT     - INTEGER OPTION FLAG
C                (+1 TO COMPUTE EARTH COORDS OF SELECTED GRID COORDS)
C                (-1 TO COMPUTE GRID COORDS OF SELECTED EARTH COORDS)
C     NPTS     - INTEGER MAXIMUM NUMBER OF COORDINATES
C     FILL     - REAL FILL VALUE TO SET INVALID OUTPUT DATA
C                (MUST BE IMPOSSIBLE VALUE; SUGGESTED VALUE: -9999.)
C     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT>0
C     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT>0
C     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT<0
C                (ACCEPTABLE RANGE: -360. TO 360.)
C     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT<0
C                (ACCEPTABLE RANGE: -90. TO 90.)
C     LROT     - INTEGER FLAG TO RETURN VECTOR ROTATIONS IF 1
C
C   OUTPUT ARGUMENT LIST:
C     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT<0
C     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT<0
C     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT>0
C     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT>0
C     NRET     - INTEGER NUMBER OF VALID POINTS COMPUTED
C     CROT     - REAL (NPTS) CLOCKWISE VECTOR ROTATION COSINES IF LROT=1
C     SROT     - REAL (NPTS) CLOCKWISE VECTOR ROTATION SINES IF LROT=1
C                (UGRID=CROT*UEARTH-SROT*VEARTH;
C                 VGRID=SROT*UEARTH+CROT*VEARTH)
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C
C$$$
      IMPLICIT NONE
      INTEGER         :: IM, JM, IROT, KGDS(200), IPROJ
      INTEGER         :: ISCAN, JSCAN, NSCAN, NRET
      INTEGER         :: ITER, NPTS, IOPT, N, LROT
      REAL            :: XPTS(NPTS),YPTS(NPTS),RLON(NPTS),RLAT(NPTS)
      REAL            :: CROT(NPTS),SROT(NPTS)
      REAL, PARAMETER :: RERTH=6.3712E6
      REAL, PARAMETER :: RERTH_WGS84=6.378137E6
      REAL, PARAMETER :: PI=3.14159265358979
      REAL, PARAMETER :: DPR=180./PI
      REAL, PARAMETER :: PI2=PI/2.0
      REAL, PARAMETER :: PI4=PI/4.0
      REAL, PARAMETER :: E2=.00669437999013  ! wgs84 datum
      REAL, PARAMETER :: SLAT=60.0  ! standard latitude according
                                    ! to grib standard
      REAL, PARAMETER :: SLATR=SLAT/DPR
      REAL            :: MC, RLAT1, RLON1, ORIENT, DX, DY, H, HI, HJ
      REAL            :: DXS, DYS, DE, DR, XP, YP, DE2, ALAT, ALONG
      REAL            :: T, RHO, TC, XMIN, XMAX, YMIN, YMAX, DI, DJ
      REAL            :: ALAT1, DR2, DIFF, FILL, E, E_OVER_2
      LOGICAL         :: ELLIPTICAL
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IF(KGDS(1).EQ.005) THEN
        ELLIPTICAL=MOD(KGDS(6)/64,2).EQ.1
        IM=KGDS(2)
        JM=KGDS(3)
        RLAT1=KGDS(4)*1.E-3
        RLON1=KGDS(5)*1.E-3
        IROT=MOD(KGDS(6)/8,2)
        ORIENT=KGDS(7)*1.E-3
        DX=KGDS(8)
        DY=KGDS(9)
        IPROJ=MOD(KGDS(10)/128,2)
        ISCAN=MOD(KGDS(11)/128,2)
        JSCAN=MOD(KGDS(11)/64,2)
        NSCAN=MOD(KGDS(11)/32,2)
        H=(-1.)**IPROJ
        IF(H.EQ.-1)ORIENT=ORIENT+180.
        HI=(-1.)**ISCAN
        HJ=(-1.)**(1-JSCAN)
        DXS=DX*HI
        DYS=DY*HJ
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C FIND X/Y OF POLE
        IF (.NOT.ELLIPTICAL) THEN
          DE=(1.+SIN(SLAT/DPR))*RERTH
          DR=DE*COS(RLAT1/DPR)/(1+H*SIN(RLAT1/DPR))
          XP=1-H*SIN((RLON1-ORIENT)/DPR)*DR/DXS
          YP=1+COS((RLON1-ORIENT)/DPR)*DR/DYS
          DE2=DE**2
        ELSE
          E=SQRT(E2)
          E_OVER_2=E*0.5
          ALAT=H*RLAT1/DPR
          ALONG = (RLON1-ORIENT)/DPR
          T=TAN(PI4-ALAT/2.)/((1.-E*SIN(ALAT))/
     &      (1.+E*SIN(ALAT)))**(E_OVER_2)
          TC=TAN(PI4-SLATR/2.)/((1.-E*SIN(SLATR))/
     &      (1.+E*SIN(SLATR)))**(E_OVER_2)
          MC=COS(SLATR)/SQRT(1.0-E2*(SIN(SLATR)**2))
          RHO=RERTH_WGS84*MC*T/TC
          YP = 1.0 + RHO*COS(H*ALONG)/DYS
          XP = 1.0 - RHO*SIN(H*ALONG)/DXS
        ENDIF ! ELLIPTICAL
        XMIN=0
        XMAX=IM+1
        YMIN=0
        YMAX=JM+1
        NRET=0
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  TRANSLATE GRID COORDINATES TO EARTH COORDINATES
        IF(IOPT.EQ.0.OR.IOPT.EQ.1) THEN
          IF(.NOT.ELLIPTICAL)THEN
            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
                DI=(XPTS(N)-XP)*DXS
                DJ=(YPTS(N)-YP)*DYS
                DR2=DI**2+DJ**2
                IF(DR2.LT.DE2*1.E-6) THEN
                  RLON(N)=0.
                  RLAT(N)=H*90.
                ELSE
                  RLON(N)=MOD(ORIENT+H*DPR*ATAN2(DI,-DJ)+3600,360.)
                  RLAT(N)=H*DPR*ASIN((DE2-DR2)/(DE2+DR2))
                ENDIF
                NRET=NRET+1
                IF(LROT.EQ.1) THEN
                  IF(IROT.EQ.1) THEN
                    CROT(N)=H*COS((RLON(N)-ORIENT)/DPR)
                    SROT(N)=SIN((RLON(N)-ORIENT)/DPR)
                  ELSE
                    CROT(N)=1
                    SROT(N)=0
                  ENDIF
                ENDIF
              ELSE
                RLON(N)=FILL
                RLAT(N)=FILL
              ENDIF
            ENDDO
          ELSE ! ELLIPTICAL
            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
                DI=(XPTS(N)-XP)*DXS
                DJ=(YPTS(N)-YP)*DYS
                RHO=SQRT(DI*DI+DJ*DJ)
                T=(RHO*TC)/(RERTH_WGS84*MC)
                IF(ABS(YPTS(N)-YP)<0.01)THEN
                  IF(DI>0.0) ALONG=ORIENT+H*90.0
                  IF(DI<=0.0) ALONG=ORIENT-H*90.0
                ELSE
                  ALONG=ORIENT+H*ATAN(DI/(-DJ))*DPR
                  IF(DJ>0) ALONG=ALONG+180.
                END IF
                ALAT1=PI2-2.0*ATAN(T)
                DO ITER=1,10
                  ALAT = PI2 - 2.0*ATAN(T*(((1.0-E*SIN(ALAT1))/
     &                  (1.0+E*SIN(ALAT1)))**(E_OVER_2)))
                  DIFF = ABS(ALAT-ALAT1)*DPR
                  IF (DIFF < 0.000001) EXIT
                  ALAT1=ALAT
                ENDDO
                RLAT(N)=H*ALAT*DPR
                RLON(N)=ALONG
                IF(RLON(N)<0.0) RLON(N)=RLON(N)+360.
                IF(RLON(N)>360.0) RLON(N)=RLON(N)-360.0
                NRET=NRET+1
                IF(LROT.EQ.1) THEN
                  IF(IROT.EQ.1) THEN
                    CROT(N)=H*COS((RLON(N)-ORIENT)/DPR)
                    SROT(N)=SIN((RLON(N)-ORIENT)/DPR)
                  ELSE
                    CROT(N)=1
                    SROT(N)=0
                  ENDIF
                ENDIF
              ELSE
                RLON(N)=FILL
                RLAT(N)=FILL
              ENDIF
            ENDDO
          ENDIF ! ELLIPTICAL
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  TRANSLATE EARTH COORDINATES TO GRID COORDINATES
        ELSEIF(IOPT.EQ.-1) THEN
          IF(.NOT.ELLIPTICAL)THEN
            DO N=1,NPTS
              IF(ABS(RLON(N)).LE.360.AND.ABS(RLAT(N)).LE.90.AND.
     &                                   H*RLAT(N).NE.-90) THEN
                DR=DE*TAN((90-H*RLAT(N))/2/DPR)
                XPTS(N)=XP+H*SIN((RLON(N)-ORIENT)/DPR)*DR/DXS
                YPTS(N)=YP-COS((RLON(N)-ORIENT)/DPR)*DR/DYS
                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.EQ.1) THEN
                    IF(IROT.EQ.1) THEN
                      CROT(N)=H*COS((RLON(N)-ORIENT)/DPR)
                      SROT(N)=SIN((RLON(N)-ORIENT)/DPR)
                    ELSE
                      CROT(N)=1
                      SROT(N)=0
                    ENDIF
                  ENDIF
                ELSE
                  XPTS(N)=FILL
                  YPTS(N)=FILL
                ENDIF
              ELSE
                XPTS(N)=FILL
                YPTS(N)=FILL
              ENDIF
            ENDDO
          ELSE ! ELLIPTICAL CALCS
            DO N=1,NPTS
              IF(ABS(RLON(N)).LE.360.AND.ABS(RLAT(N)).LE.90.AND.
     &                                   H*RLAT(N).NE.-90) THEN
                ALAT = H*RLAT(N)/DPR
                ALONG = (RLON(N)-ORIENT)/DPR
                T=TAN(PI4-ALAT*0.5)/((1.-E*SIN(ALAT))/
     &            (1.+E*SIN(ALAT)))**(E_OVER_2)
                RHO=RERTH_WGS84*MC*T/TC
                XPTS(N)= XP + RHO*SIN(H*ALONG) / DXS
                YPTS(N)= YP - RHO*COS(H*ALONG) / DYS
                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.EQ.1) THEN
                    IF(IROT.EQ.1) THEN
                      CROT(N)=H*COS((RLON(N)-ORIENT)/DPR)
                      SROT(N)=SIN((RLON(N)-ORIENT)/DPR)
                    ELSE
                      CROT(N)=1
                      SROT(N)=0
                    ENDIF
                  ENDIF
                ELSE
                  XPTS(N)=FILL
                  YPTS(N)=FILL
                ENDIF
              ELSE
                XPTS(N)=FILL
                YPTS(N)=FILL
              ENDIF
            ENDDO
          ENDIF
        ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  PROJECTION UNRECOGNIZED
      ELSE
        NRET=0
        IF(IOPT.GE.0) THEN
          DO N=1,NPTS
            RLON(N)=FILL
            RLAT(N)=FILL
          ENDDO
        ENDIF
        IF(IOPT.LE.0) THEN
          DO N=1,NPTS
            XPTS(N)=FILL
            YPTS(N)=FILL
          ENDDO
        ENDIF
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END


      subroutine fitp(am,x,px,rx,w,Ntraj,dpx,ddp,dr,ddr,u,ap,ar,err)

      implicit real*8(a-h,o-z)

      integer*4,intent(IN) :: Ntraj
      integer*4,parameter :: nb=4
      real*8 :: px(Ntraj), w(Ntraj),x(Ntraj),rx(ntraj)
      real*8 :: dpx(Ntraj),dr(ntraj),ddr(ntraj)
      real*8 :: f(nb),s(nb,nb),c(nb,1),cr(nb,1),mat(nb,nb),u(ntraj),
     +          ap(ntraj),ar(ntraj),ddp(ntraj)
      real*8 :: err(2)

      c = 0d0
      s = 0d0
      cr = 0d0

      do i=1,Ntraj
        f=(/x(i),x(i)**2,x(i)**3,1d0/)
        c(1,1) = c(1,1)+px(i)*f(1)*w(i)
        c(2,1) = c(2,1)+px(i)*f(2)*w(i)
        c(3,1) = c(3,1)+f(3)*px(i)*w(i)
        c(4,1) = c(4,1)+f(4)*px(i)*w(i)
      enddo

      do i=1,Ntraj
        f=(/x(i),x(i)**2,x(i)**3,1d0/)
        cr(1,1) = cr(1,1)+rx(i)*f(1)*w(i)
        cr(2,1) = cr(2,1)+rx(i)*f(2)*w(i)
        cr(3,1) = cr(3,1)+f(3)*rx(i)*w(i)
        cr(4,1) = cr(4,1)+f(4)*rx(i)*w(i)
      enddo

      do m=1,nb
        do n=1,nb
          do i=1,Ntraj
            f=(/x(i),x(i)**2,x(i)**3,1d0/)
            s(m,n)=w(i)*f(m)*f(n)+s(m,n)
          end do
        end do
      end do

! calculate matrix c(t)
      mat = s
        call DPOSV('U',nb,1,mat,nb,c,nb,INFO)
        if(INFO/=0) then
        print *, "info=",info
        print *, "polynomial fitting : matrix fails"
        stop
        end if

        call DPOSV('U',nb,1,s,nb,cr,nb,INFO)
        if(INFO/=0) then
        print *, "info=",info
        print *, "polynomial fitting : matrix fails"
        stop
        end if

!     check the error of poly-fit

!      call errp(ntraj,px,x,w,c,err_p)

! the momentum operator r=cf
      do i=1,Ntraj
        ap(i) = c(1,1)*x(i)+c(2,1)*x(i)**2+c(3,1)*x(i)**3+c(4,1)
        ar(i) = cr(1,1)*x(i)+cr(2,1)*x(i)**2+cr(3,1)*x(i)**3+cr(4,1)
        dpx(i) = c(1,1)+2d0*c(2,1)*x(i)+c(3,1)*3d0*x(i)**2
        ddp(i) = 2d0*c(2,1)*x(i)+6d0*x(i)*c(3,1)
        dr(i) = cr(1,1) + 2d0*x(i)*cr(2,1) + cr(3,1)*3d0*x(i)**2
        ddr(i) = 2d0*cr(2,1) + 6d0*x(i)*cr(3,1)
        u(i) = -(rx(i)**2 + dr(i))/(2d0*am)
      enddo

      err = 0d0
      do i=1,ntraj
        err(1) = err(1) + (px(i)-ap(i))**2*w(i)
        err(2) = err(2) + (rx(i)-ar(i))**2*w(i)
      enddo
!c     &             py(i)*(c(1,2)+2d0*c(3,2)*x(i)+c(5,2)*y(i))/am2
!c          dpy(i) = px(i)*(c(2,1)+2d0*c(4,1)*y(i)+c(5,1)*x(i))/am1+
!c     &             py(i)*(c(2,2)+2d0*c(4,2)*y(i)+c(5,2)*x(i))/am2
!! calculate quantum potential
!c          qp(i) = (c(1,1)+2d0*c(2,1)*x(i)+c(3,1)*3d0*x(i)**2)/2d0/am1
!c     &            (c(2,2)+2d0*c(4,2)*y(i)+c(5,2)*x(i))/2d0/am2
!c          qfx(i) = -(2d0*c(2,1)+6d0*x(i)*c(3,1))/2d0/am1
!c     qfy(i) = -(c(5,1)/2d0/am1+c(4,2)/am2)

      return
      end subroutine

!     --------------------------------
!     check the error of poly-fit of p
!     --------------------------------
      subroutine errp(nt,p,x,w,c,error)
      implicit real*8(a-h,o-z)

      integer*4, intent(in)  :: nt
      real*8,    intent(in)  :: w(nt),p(nt),x(nt),c(4,1)
      real*8,    intent(out) :: error

      error = 0d0

      do i=1,nt
        pfit = c(1,1)*x(i)+c(2,1)*x(i)**2+c(3,1)*x(i)**3+c(4,1)
        error = error + (p(i)-pfit)**2*w(i)
      enddo

      return
      end subroutine


      implicit double precision (a-h,o-z)
c
      dimension x(3000), y(3000), z(3000)
      integer :: bound_nodes(500)
      double precision :: nu, KI, kappa

      factor = 25.4d0 * 0.9842517962599695d0

      radius_mm = 2000.d0
      radius_m = 2.0d0
      pi = 3.14159265359d0
c
      read(*,*) nnode

      do i = 1, nnode
       read(*,*,end=100) j, x(j), y(j), z(j)
       x(i) = x(i) * factor
       y(i) = y(i) * factor
       z(i) = z(i) * factor
      end do

      read(*,*) nboundary
      do i = 1, nboundary
        read(*,*) bound_nodes(i)
      end do

      do i = 1, nboundary
        node = bound_nodes(i)
        xb = x(node)
        yb = y(node)
        angle = atan2(yb,xb)
        x(node) = radius_mm * cos(angle)
        y(node) = radius_mm * sin(angle)
      end do

      do i = 1, nnode
       write(*,1000)  i, x(i), y(i), z(i)
      end do

      stop  !   <<<<<<<<<<<<<<<<<<<<<<<<

      ymod = 88000.d0
      nu = 0.34d0
      gmod = ymod / 2.0d0 / (1.0d0 + nu )
      KI = 1.0d0
      applied_k = 1.0d0
      write(*,*) ' '
      write(*,*) ' '

c
c            make KI displacements on boundary for 1.0 MPa-sqrt(m)
c            Zr4 properties.
c            compute in meters, final in mm

c
      do i = 1, nboundary
        node = bound_nodes(i)
        xb = x(node)
        yb = y(node)
        theta = atan2( yb, xb )
        ct2 = cos(theta*0.5d0)
        st2 = sin(theta*0.5d0)
        ct  = cos(theta)
        st  = sin(theta)
        term1 = (3.0-4.0*nu-ct) * ct2
        term2 = (3.0-4.0*nu-ct) * st2
        term3 = sqrt( radius_m * 0.5d0 / pi )
        term4 = (1.0d0 + nu ) * applied_k / ymod
        u_k = 1000.0d0 * term4 * term3 * term1
        v_k = 1000.0d0 * term4 * term3 * term2
        write(*,2000) node, u_k, v_k
      end do

c
 100  stop
 1000 format(i6,3e17.9)
 2000 format(i9,1x,'u ',e17.9,3x,'v ',e17.9)
      end


      SUBROUTINE DMIXP(A,B,BETA,ICY,ID,NMSH,
     1                 C,D,VN1,VN12,VN2,VN22)
C
C  *************************************************************
C  *
C  *    ADAPTED FROM K.C.PANDEY
C  *    USING ANDERSON'S EXTRAPOLATION SCHEME
C  *    EQS 4.1-4.9,4.15-4.18 OF
C  *    D.G.ANDERSON J.ASSOC.COMPUTING MACHINERY,12,547(1965)
C  *    COMPUTES A NEW VECTOR IN A ITERATIVE SCHEME
C  *    INPUT A=NEWPOT B=OLDPOT
C  *    OUTPUT A=A-B B=NEWPOT
C  *    BETA=MIXING,IN=ITER. NUMBER
C  *    ID=1,2 OR 3 DIFF CONV METH.
C  *    ICY CYCLE NUMBER ,ICY=1 ON FIRST/ZEROTH CALL
C  *    C,D WORK ARRAYS OF SIZE NMSH
C  *    VN1,VN12,VN2,VN22 STORAGE ARRAYS OF SIZE NMSH
C  *
C  *
C  *
C  *
C  *************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (UZE=0.0D0,UM=1.0D0,DETOL=1.D-9)
C
      DIMENSION A(NMSH),B(NMSH),C(NMSH),D(NMSH)
      DIMENSION VN1(NMSH),VN12(NMSH),VN2(NMSH),VN22(NMSH)
      IN=ICY-1
      IF(IN.EQ.0) THEN
        CALL TRNSVV(B,A,UM,NMSH)
        RETURN
      ENDIF
      CALL TRNSVV(A,B,-UM,NMSH)
      CALL DOTTVV(A,A,R2,NMSH)
      IF(ID.EQ.1) THEN
        CALL TRNSVV(B,A,BETA,NMSH)
        RETURN
      ENDIF
      IF(IN.EQ.1) THEN
        DO 100 I=1,NMSH
          VN1(I)=A(I)
 100    CONTINUE
        DO 105 I=1,NMSH
          VN2(I)=B(I)
 105    CONTINUE
        CALL TRNSVV(B,A,BETA,NMSH)
        RETURN
      ENDIF
      DO 110 I=1,NMSH
        C(I)=VN1(I)
 110  CONTINUE
      IF(ID.EQ.3.AND.IN.GT.2) THEN
        DO 115 I=1,NMSH
          D(I)=VN12(I)
 115    CONTINUE
      ENDIF
      DO 120 I=1,NMSH
        VN1(I)=A(I)
 120  CONTINUE
      IF(ID.GT.2.AND.IN.GT.1) THEN
        DO 125 I=1,NMSH
          VN12(I)=C(I)
 125    CONTINUE
      ENDIF
      CALL TRNSVV(C,A,-UM,NMSH)
      CALL DOTTVV(C,C,D11,NMSH)
      CALL DOTTVV(A,C,RD1M,NMSH)
      IF(IN.LE.2.OR.ID.LE.2) THEN
        T1=-RD1M/D11
        X=UM-T1
        BT1=BETA*T1
        DO 5 I=1,NMSH
          A(I)=BETA*A(I)
 5      CONTINUE
        CALL TRNSVV(A,C,BT1,NMSH)
        DO 130 I=1,NMSH
          D(I)=VN2(I)
 130    CONTINUE
        CALL TRNSVV(A,D,T1,NMSH)
        DO 135 I=1,NMSH
          VN2(I)=B(I)
 135    CONTINUE
        IF(ID.GT.2.AND.IN.EQ.2) THEN
          DO 140 I=1,NMSH
            VN22(I)=D(I)
 140      CONTINUE
        ENDIF
        DO 10 I=1,NMSH
          B(I)=X*B(I)+A(I)
 10     CONTINUE
        RETURN
      ENDIF
      CALL TRNSVV(D,A,-UM,NMSH)
      CALL DOTTVV(D,D,D22,NMSH)
      CALL DOTTVV(C,D,D12,NMSH)
      CALL DOTTVV(A,D,RD2M,NMSH)
      A2=D11*D22
      DET=A2-D12*D12
      DETT=DET/A2
      IF(ABS(DETT).GE.DETOL) THEN
        T1=(-RD1M*D22+RD2M*D12)/DET
        T2=( RD1M*D12-RD2M*D11)/DET
      ELSE
        T1=-RD1M/D11
        T2=UZE
      ENDIF
      X=UM-T1-T2
      BT1=BETA*T1
      BT2=BETA*T2
      DO 15 I=1,NMSH
        A(I)=BETA*A(I)
 15   CONTINUE
      CALL TRNSVV(A,C,BT1,NMSH)
      CALL TRNSVV(A,D,BT2,NMSH)
      CALL TRNSVV(A,VN2,T1,NMSH)
      CALL TRNSVV(A,VN22,T2,NMSH)
      DO 145 I=1,NMSH
        VN22(I)=VN2(I)
 145  CONTINUE
      DO 155 I=1,NMSH
        VN2(I)=B(I)
 155  CONTINUE
      DO 20 I=1,NMSH
        B(I)=X*B(I)+A(I)
 20   CONTINUE
      RETURN
      END


*> \brief \b ZLATSY
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZLATSY( UPLO, N, X, LDX, ISEED )
*
*       .. Scalar Arguments ..
*       CHARACTER          UPLO
*       INTEGER            LDX, N
*       ..
*       .. Array Arguments ..
*       INTEGER            ISEED( * )
*       COMPLEX*16         X( LDX, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZLATSY generates a special test matrix for the complex symmetric
*> (indefinite) factorization.  The pivot blocks of the generated matrix
*> will be in the following order:
*>    2x2 pivot block, non diagonalizable
*>    1x1 pivot block
*>    2x2 pivot block, diagonalizable
*>    (cycle repeats)
*> A row interchange is required for each non-diagonalizable 2x2 block.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER
*>          Specifies whether the generated matrix is to be upper or
*>          lower triangular.
*>          = 'U':  Upper triangular
*>          = 'L':  Lower triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The dimension of the matrix to be generated.
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*>          X is COMPLEX*16 array, dimension (LDX,N)
*>          The generated matrix, consisting of 3x3 and 2x2 diagonal
*>          blocks which result in the pivot sequence given above.
*>          The matrix outside of these diagonal blocks is zero.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*>          LDX is INTEGER
*>          The leading dimension of the array X.
*> \endverbatim
*>
*> \param[in,out] ISEED
*> \verbatim
*>          ISEED is INTEGER array, dimension (4)
*>          On entry, the seed for the random number generator.  The last
*>          of the four integers must be odd.  (modified on exit)
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16_lin
*
*  =====================================================================
      SUBROUTINE ZLATSY( UPLO, N, X, LDX, ISEED )
*
*  -- LAPACK test routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            LDX, N
*     ..
*     .. Array Arguments ..
      INTEGER            ISEED( * )
      COMPLEX*16         X( LDX, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX*16         EYE
      PARAMETER          ( EYE = ( 0.0D0, 1.0D0 ) )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J, N5
      DOUBLE PRECISION   ALPHA, ALPHA3, BETA
      COMPLEX*16         A, B, C, R
*     ..
*     .. External Functions ..
      COMPLEX*16         ZLARND
      EXTERNAL           ZLARND
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, SQRT
*     ..
*     .. Executable Statements ..
*
*     Initialize constants
*
      ALPHA = ( 1.D0+SQRT( 17.D0 ) ) / 8.D0
      BETA = ALPHA - 1.D0 / 1000.D0
      ALPHA3 = ALPHA*ALPHA*ALPHA
*
*     UPLO = 'U':  Upper triangular storage
*
      IF( UPLO.EQ.'U' ) THEN
*
*        Fill the upper triangle of the matrix with zeros.
*
         DO 20 J = 1, N
            DO 10 I = 1, J
               X( I, J ) = 0.0D0
   10       CONTINUE
   20    CONTINUE
         N5 = N / 5
         N5 = N - 5*N5 + 1
*
         DO 30 I = N, N5, -5
            A = ALPHA3*ZLARND( 5, ISEED )
            B = ZLARND( 5, ISEED ) / ALPHA
            C = A - 2.D0*B*EYE
            R = C / BETA
            X( I, I ) = A
            X( I-2, I ) = B
            X( I-2, I-1 ) = R
            X( I-2, I-2 ) = C
            X( I-1, I-1 ) = ZLARND( 2, ISEED )
            X( I-3, I-3 ) = ZLARND( 2, ISEED )
            X( I-4, I-4 ) = ZLARND( 2, ISEED )
            IF( ABS( X( I-3, I-3 ) ).GT.ABS( X( I-4, I-4 ) ) ) THEN
               X( I-4, I-3 ) = 2.0D0*X( I-3, I-3 )
            ELSE
               X( I-4, I-3 ) = 2.0D0*X( I-4, I-4 )
            END IF
   30    CONTINUE
*
*        Clean-up for N not a multiple of 5.
*
         I = N5 - 1
         IF( I.GT.2 ) THEN
            A = ALPHA3*ZLARND( 5, ISEED )
            B = ZLARND( 5, ISEED ) / ALPHA
            C = A - 2.D0*B*EYE
            R = C / BETA
            X( I, I ) = A
            X( I-2, I ) = B
            X( I-2, I-1 ) = R
            X( I-2, I-2 ) = C
            X( I-1, I-1 ) = ZLARND( 2, ISEED )
            I = I - 3
         END IF
         IF( I.GT.1 ) THEN
            X( I, I ) = ZLARND( 2, ISEED )
            X( I-1, I-1 ) = ZLARND( 2, ISEED )
            IF( ABS( X( I, I ) ).GT.ABS( X( I-1, I-1 ) ) ) THEN
               X( I-1, I ) = 2.0D0*X( I, I )
            ELSE
               X( I-1, I ) = 2.0D0*X( I-1, I-1 )
            END IF
            I = I - 2
         ELSE IF( I.EQ.1 ) THEN
            X( I, I ) = ZLARND( 2, ISEED )
            I = I - 1
         END IF
*
*     UPLO = 'L':  Lower triangular storage
*
      ELSE
*
*        Fill the lower triangle of the matrix with zeros.
*
         DO 50 J = 1, N
            DO 40 I = J, N
               X( I, J ) = 0.0D0
   40       CONTINUE
   50    CONTINUE
         N5 = N / 5
         N5 = N5*5
*
         DO 60 I = 1, N5, 5
            A = ALPHA3*ZLARND( 5, ISEED )
            B = ZLARND( 5, ISEED ) / ALPHA
            C = A - 2.D0*B*EYE
            R = C / BETA
            X( I, I ) = A
            X( I+2, I ) = B
            X( I+2, I+1 ) = R
            X( I+2, I+2 ) = C
            X( I+1, I+1 ) = ZLARND( 2, ISEED )
            X( I+3, I+3 ) = ZLARND( 2, ISEED )
            X( I+4, I+4 ) = ZLARND( 2, ISEED )
            IF( ABS( X( I+3, I+3 ) ).GT.ABS( X( I+4, I+4 ) ) ) THEN
               X( I+4, I+3 ) = 2.0D0*X( I+3, I+3 )
            ELSE
               X( I+4, I+3 ) = 2.0D0*X( I+4, I+4 )
            END IF
   60    CONTINUE
*
*        Clean-up for N not a multiple of 5.
*
         I = N5 + 1
         IF( I.LT.N-1 ) THEN
            A = ALPHA3*ZLARND( 5, ISEED )
            B = ZLARND( 5, ISEED ) / ALPHA
            C = A - 2.D0*B*EYE
            R = C / BETA
            X( I, I ) = A
            X( I+2, I ) = B
            X( I+2, I+1 ) = R
            X( I+2, I+2 ) = C
            X( I+1, I+1 ) = ZLARND( 2, ISEED )
            I = I + 3
         END IF
         IF( I.LT.N ) THEN
            X( I, I ) = ZLARND( 2, ISEED )
            X( I+1, I+1 ) = ZLARND( 2, ISEED )
            IF( ABS( X( I, I ) ).GT.ABS( X( I+1, I+1 ) ) ) THEN
               X( I+1, I ) = 2.0D0*X( I, I )
            ELSE
               X( I+1, I ) = 2.0D0*X( I+1, I+1 )
            END IF
            I = I + 2
         ELSE IF( I.EQ.N ) THEN
            X( I, I ) = ZLARND( 2, ISEED )
            I = I + 1
         END IF
      END IF
*
      RETURN
*
*     End of ZLATSY
*
      END


      subroutine potslw (dv,d,dr,dpas,np)
c
c coulomb potential uses a 4-point integration method
c dv=potential;  d=density;  dp=bloc de travail; dr=radial mesh
c dpas=exponential step;
c np=number of points
c **********************************************************************

      implicit double precision (a-h,o-z)
      dimension dv(251), d(251), dp(251), dr(251)

      das=dpas/24.0
      do i=1,np
         dv(i)=d(i)*dr(i)
      enddo
      dlo=exp(dpas)
      dlo2=dlo*dlo
      dp(2)=dr(1)*(d(2)-d(1)*dlo2)/(12.0*(dlo-1.0))
      dp(1)=dv(1)/3.0-dp(2)/dlo2
      dp(2)=dv(2)/3.0-dp(2)*dlo2
      j=np-1
      do i=3,j
         dp(i)=dp(i-1)+das*(13.0*(dv(i)+dv(i-1))-(dv(i-2)+dv(i+1)))
      enddo
      dp(np)=dp(j)
      dv(j)=dp(j)
      dv(np)=dp(j)
      do i=3,j
         k=np+1-i
         dv(k)=dv(k+1)/dlo+das*
     $        (13.0*(dp(k+1)/dlo+dp(k)) - (dp(k+2)/dlo2 + dp(k-1)*dlo))
      enddo
      dv(1)=dv(3)/dlo2+dpas*(dp(1)+4.0*dp(2)/dlo+dp(3)/dlo2)/3.0
      do i=1,np
         dv(i)=dv(i)/dr(i)
      enddo
      return
      end


MODULE caldyn_gcm_mod
   use mod_misc
   PRIVATE
   TYPE(t_message) :: req_ps, req_mass, req_theta_rhodz, req_u, req_qu

   public compute_geopot

CONTAINS

   SUBROUTINE compute_geopot(ps,rhodz,theta, pk,geopot)
      use prec
      use mod_misc
      IMPLICIT NONE
      REAL(rstd),INTENT(INOUT) :: ps(iim*jjm)
      REAL(rstd),INTENT(IN)    :: rhodz(iim*jjm,llm)
      REAL(rstd),INTENT(IN)    :: theta(iim*jjm,llm)    ! potential temperature
      REAL(rstd),INTENT(INOUT) :: pk(iim*jjm,llm)       ! Exner function
      REAL(rstd),INTENT(INOUT) :: geopot(iim*jjm,llm+1) ! geopotential

      INTEGER :: i,j,ij,l
      REAL(rstd) :: p_ik, exner_ik

      CALL trace_start("compute_geopot")

      IF(caldyn_eta==eta_mass) THEN

!!! Compute exner function and geopotential
         DO l = 1,llm
            !DIR$ SIMD
            DO ij=ij_begin_ext,ij_end_ext
               p_ik = ptop + mass_ak(l) + mass_bk(l)*ps(ij) ! FIXME : leave ps for the moment ; change ps to Ms later
               !         p_ik = ptop + g*(mass_ak(l)+ mass_bk(l)*ps(i,j))
               exner_ik = cpp * (p_ik/preff) ** kappa
               pk(ij,l) = exner_ik
               ! specific volume v = kappa*theta*pi/p = dphi/g/rhodz
               if ( p_ik > 1.D-30 ) then
                  geopot(ij,l+1) = geopot(ij,l) + (g*kappa)*rhodz(ij,l)*theta(ij,l)*exner_ik/p_ik
               endif
            ENDDO
         ENDDO
         !       ENDIF
      ELSE
         ! We are using a Lagrangian vertical coordinate
         ! Pressure must be computed first top-down (temporarily stored in pk)
         ! Then Exner pressure and geopotential are computed bottom-up
         ! Notice that the computation below should work also when caldyn_eta=eta_mass

         IF(boussinesq) THEN ! compute only geopotential : pressure pk will be computed in compute_caldyn_horiz
            ! specific volume 1 = dphi/g/rhodz
            !         IF (is_omp_level_master) THEN ! no openMP on vertical due to dependency
            DO l = 1,llm
               !DIR$ SIMD
               DO ij=ij_begin_ext,ij_end_ext
                  geopot(ij,l+1) = geopot(ij,l) + g*rhodz(ij,l)
               ENDDO
            ENDDO
         ELSE ! non-Boussinesq, compute geopotential and Exner pressure
            ! uppermost layer

            !DIR$ SIMD
            DO ij=ij_begin_ext,ij_end_ext
               pk(ij,llm) = ptop + (.5*g)*rhodz(ij,llm)
            END DO
            ! other layers
            DO l = llm-1, 1, -1
               !DIR$ SIMD
               DO ij=ij_begin_ext,ij_end_ext
                  pk(ij,l) = pk(ij,l+1) + (.5*g)*(rhodz(ij,l)+rhodz(ij,l+1))
               END DO
            END DO
            ! surface pressure (for diagnostics)
            DO ij=ij_begin_ext,ij_end_ext
               ps(ij) = pk(ij,1) + (.5*g)*rhodz(ij,1)
            END DO

            ! specific volume v = kappa*theta*pi/p = dphi/g/rhodz
            DO l = 1,llm
               !DIR$ SIMD
               DO ij=ij_begin_ext,ij_end_ext
                  p_ik = pk(ij,l)
                  exner_ik = cpp * (p_ik/preff) ** kappa
                  geopot(ij,l+1) = geopot(ij,l) + (g*kappa)*rhodz(ij,l)*theta(ij,l)*exner_ik/p_ik
                  pk(ij,l) = exner_ik
               ENDDO
            ENDDO
         END IF

      END IF

      !ym flush geopot
      !$OMP BARRIER

      CALL trace_end("compute_geopot")

   END SUBROUTINE compute_geopot

END MODULE caldyn_gcm_mod


module utilities

  use global_variables  ! Acces to global definition and properties
  use IO                ! Input/Output definitions, display procedures and reading procedures for input files

  !*****************************************************************************************************************
  !
  ! OVERVIEW
  !
  ! General purpose (e.g. interpolation) routines used by (but not specifically related to) the G.A.S model
  !
  ! NO SUBROUTINES IN THIS MODULE
  !
  ! FUNCTION IN THIS MODULE
  !
  ! dt2dz                            :: compute redshift interval corresponding to a time interval at a given redshift
  !
  ! is_NaN                           :: Allows to test if a number is not defined correctly (Not a Number)
  !                                     Return .true. if x is not a number
  !
  ! BESSI0                           :: "I" Bessel function of rank 0
  !
  ! BESSI1                           :: "I" Bessel function of rank 1
  !
  ! BESSK0                           :: "K" Bessel function of rank 0
  !
  ! BESSK1                           :: "K" Bessel function of rank 1
  !
  ! slope_limiter(x,x0)              :: Reduce the evolution rate of a given properties (x)
  !                                        allows to slowly approach the resolution limit (x0)
  !
  ! Ronbint(f, a, b, err, param ...) :: Compute the integral of the function "f" between "a" and "b"
  !                                        The function "f" can be defined with some parameters given in the input array "param"
  !
  ! trap                             :: simple trapezium rule to integrate y over a pre-tabulated x array
  !
  ! Normal_distribution(mean,sigma)  :: Returns a random variable "x" following a normal distribution of mean "mean" and of standard deviation "sigma"
  !
  ! erf_func(x)                      :: Compute the standard error function
  !
  ! locate2D                         :: Returns the value stored in pre-tabulted 2D-table
  !
  !*****************************************************************************************************************

  contains

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

  function dt2dz(dt,z)

    ! COMPUTE THE 'dz' KNOWING THE 'dt'
    ! at a given z

    implicit none

    real(kind=8),intent(in)      :: dt, z   ! in Gyr and without unit
    real(kind=8)                 :: dt2dz   ! without unit

    dt2dz = (Omega_m*z+1.d0)*(1.d0+z)**2. - Omega_L*z*(z+2.d0)
    dt2dz = -1.d2*h_0_code_unit*(1.d0+z)*sqrt(dt2dz)*dt

    return
  end function dt2dz

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

  function is_NaN(x)

    ! Return .true. if x is not a number

    implicit none

    logical         :: is_NaN ! is true if

    real(kind=8)    :: x      ! is not a number

    if (x == x) then
      !
      is_NaN = .false.
    else
      !
      is_NaN = .true.
    endif

    return

  end function is_NaN

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

  pure function BESSI0(X)

    ! "I" Bessel function of rank 0

    implicit none

    real(kind=8),intent(in) :: X
    real(kind=8)            :: BESSI0,Y,AX,BX
    real(kind=8),parameter  :: P1 = 1.d0
    real(kind=8),parameter  :: P2 = 3.5156229d0
    real(kind=8),parameter  :: P3 = 3.0899424d0
    real(kind=8),parameter  :: P4 = 1.2067429d0
    real(kind=8),parameter  :: P5 = 0.2659732d0
    real(kind=8),parameter  :: P6 = 0.360768d-1
    real(kind=8),parameter  :: P7 = 0.45813d-2
    real(kind=8),parameter  :: Q1 = 0.39894228d0
    real(kind=8),parameter  :: Q2 = 0.1328592d-1
    real(kind=8),parameter  :: Q3 = 0.225319d-2
    real(kind=8),parameter  :: Q4 = -0.157565d-2
    real(kind=8),parameter  :: Q5 = 0.916281d-2
    real(kind=8),parameter  :: Q6 = -0.2057706d-1
    real(kind=8),parameter  :: Q7 = 0.2635537d-1
    real(kind=8),parameter  :: Q8 = -0.1647633d-1
    real(kind=8),parameter  :: Q9 = 0.392377d-2

    if(abs(X) .lt. 3.75d0) then
      !
      Y=(X/3.75D0)**2
      BESSI0=P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7)))))
    else
      !
      AX=abs(X)
      Y=3.75D0/AX
      BX=exp(AX)/sqrt(AX)
      AX=Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*(Q5+Y*(Q6+Y*(Q7+Y*(Q8+Y*Q9)))))))
      BESSI0=AX*BX
    endif

    return

  end function BESSI0

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

  pure function BESSI1(X)

    ! "I" Bessel function of rank 1

    implicit none

    real(kind=8), intent(in)  :: X
    real(kind=8)              :: BESSI1,Y,AX,BX
    real(kind=8),parameter    :: P1 = 0.5d0
    real(kind=8),parameter    :: P2 = 0.87890594d0
    real(kind=8),parameter    :: P3 = 0.51498869d0
    real(kind=8),parameter    :: P4 = 0.15084934d0
    real(kind=8),parameter    :: P5 = 0.2658733d-1
    real(kind=8),parameter    :: P6 = 0.301532d-2
    real(kind=8),parameter    :: P7 = 0.32411d-3
    real(kind=8),parameter    :: Q1 = 0.39894228d0
    real(kind=8),parameter    :: Q2 = -0.3988024d-1
    real(kind=8),parameter    :: Q3 = -0.362018d-2
    real(kind=8),parameter    :: Q4 = 0.163801d-2
    real(kind=8),parameter    :: Q5 = -0.1031555d-1
    real(kind=8),parameter    :: Q6 = 0.2282967d-1
    real(kind=8),parameter    :: Q7 = -0.2895312d-1
    real(kind=8),parameter    :: Q8 = 0.1787654d-1
    real(kind=8),parameter    :: Q9 = -0.420059d-2

    if(abs(X) .lt. 3.75D0) then
      !
      Y=(X/3.75D0)**2
      BESSI1=X*(P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7))))))
    else
      !
      AX=abs(X)
      Y=3.75D0/AX
      BX=exp(AX)/sqrt(AX)
      AX=Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*(Q5+Y*(Q6+Y*(Q7+Y*(Q8+Y*Q9)))))))
      BESSI1=AX*BX
    endif

    return

  end function BESSI1

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

  pure function BESSK0(X)

    ! "K" Bessel function of rank 0

    implicit none

    real(kind=8), intent(in)  :: X
    real(kind=8)              :: BESSK0,Y,AX
    real(kind=8),parameter    :: P1 = -0.57721566d0
    real(kind=8),parameter    :: P2 = 0.42278420d0
    real(kind=8),parameter    :: P3 = 0.23069756d0
    real(kind=8),parameter    :: P4 = 0.3488590d-1
    real(kind=8),parameter    :: P5 = 0.262698d-2
    real(kind=8),parameter    :: P6 = 0.10750d-3
    real(kind=8),parameter    :: P7 = 0.74d-5
    real(kind=8),parameter    :: Q1 = 1.25331414d0
    real(kind=8),parameter    :: Q2 = -0.7832358d-1
    real(kind=8),parameter    :: Q3 = 0.2189568d-1
    real(kind=8),parameter    :: Q4 = -0.1062446d-1
    real(kind=8),parameter    :: Q5 = 0.587872d-2
    real(kind=8),parameter    :: Q6 = -0.251540d-2
    real(kind=8),parameter    :: Q7 = 0.53208d-3

    if(X .eq. 0.D0) then
      !
      BESSK0=1.D30
      return
    endif

    if(X .le. 2.D0) then
      !
      Y=X*X/4.D0
      AX=-log(X/2.D0)*BESSI0(X)
      BESSK0=AX+(P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7))))))
    else
      !
      Y=(2.D0/X)
      AX=exp(-X)/sqrt(X)
      BESSK0=AX*(Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*(Q5+Y*(Q6+Y*Q7))))))
    endif

    return

  end function BESSK0

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

  pure function BESSK1(X)

    ! "K" Bessel function of rank 1

    implicit none

    real(kind=8),intent(in)  :: X
    real(kind=8)             :: BESSK1,Y,AX
    real(kind=8),parameter   :: P1 = 1.d0
    real(kind=8),parameter   :: P2 = 0.15443144d0
    real(kind=8),parameter   :: P3 = -0.67278579d0
    real(kind=8),parameter   :: P4 = -0.18156897d0
    real(kind=8),parameter   :: P5 = -0.1919402d-1
    real(kind=8),parameter   :: P6 = -0.110404d-2
    real(kind=8),parameter   :: P7 = -0.4686d-4
    real(kind=8),parameter   :: Q1 = 1.25331414d0
    real(kind=8),parameter   :: Q2 = 0.23498619d0
    real(kind=8),parameter   :: Q3 = -0.3655620d-1
    real(kind=8),parameter   :: Q4 = 0.1504268d-1
    real(kind=8),parameter   :: Q5 = -0.780353d-2
    real(kind=8),parameter   :: Q6 = 0.325614d-2
    real(kind=8),parameter   :: Q7 = -0.68245d-3

    if(X .eq. 0.D0) then
      !
      BESSK1=1.D32
      return
    endif

    if(X .le. 2.D0) then
      !
      Y=X*X/4.D0
      AX=log(X/2.D0)*BESSI1(X)
      BESSK1=AX+(1.D0/X)*(P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7))))))
    else
      !
      Y=(2.D0/X)
      AX=exp(-X)/sqrt(X)
      BESSK1=AX*(Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*(Q5+Y*(Q6+Y*Q7))))))
    endif

    return

  end function BESSK1

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

  function slope_limiter(x,x0)

    ! Allows to reduce the derivative function (slope) associated to a given properties
    ! Allows to slowly approach the resolution limit

    implicit none

    real(kind=8),intent(in)  :: x,x0  !
    real(kind=8)             :: slope_limiter

    slope_limiter = 0.d0

    if (x .le. x0) return

    slope_limiter = 1.d0 - exp(-abs(x-x0)/abs(2.d0*x0))

    return
  end function slope_limiter

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

  function Ronbint(f, a, b, param, error, final_order, called_by)

    ! Return the integral of the function f between a and b by using the
    ! Romberg method

    implicit none

    integer(kind=4)                               :: order
    integer(kind=4),parameter                     :: maxorder = 12
    integer(kind=4)                               :: loopk
    integer(kind=4)                               :: loopj
    integer(kind=4),intent(out),optional          :: final_order

    character(*),intent(in),optional              :: called_by    ! name of the calling subroutine

    real(kind=8),intent(in)                       :: a            ! min range integration
    real(kind=8),intent(in)                       :: b            ! max range integration
    real(kind=8)                                  :: Ronbint
    real(kind=8)                                  :: f
    real(kind=8),intent(in),optional,dimension(:) :: param        ! parameters array
    real(kind=8),intent(out),optional             :: error
    real(kind=8)                                  :: e
    real(kind=8)                                  :: dh
    real(kind=8)                                  :: R(0:maxorder, 0:maxorder)

    external                                      :: f

    if (a .gt. b) then
      !
      call IO_print_error_message('Ronbint : a > b',only_rank = rank,called_by = called_by)
      stop
    end if

    order  = 0        ! init
    dh     = b - a    ! init
    e      = 1.d0     ! init
    R(:,:) = 0.d0     ! init
    R(0,0) = dh/2.d0*(f(a,param) + f(b,param))  ! first term
    !
    do while (order .lt. maxorder)
      !
      order = order + 1
      dh = dh/2.d0
      R(order, 0) = 5.d-1*R(order-1, 0)
      !
      do loopk = 1, 2**(order-1)
        !
        R(order, 0) = R(order, 0) + dh*f(a + (2.d0*real(loopk,8)-1.d0)*dh, param)
      end do
      !
      do loopj = 1, order
        !
        R(order, loopj) = R(order, loopj-1) + (R(order, loopj -1) - R(order -1, loopj -1))/(4.d0**(real(loopj,8)) - 1.d0)
      end do
      !
      if (R(order, order) .gt. 0.d0) then
        !
        e = abs(R(order, order) - R(order -1, order -1))/(R(order, order))
        if ((e .lt. num_precision) .and. (order .gt. 6)) exit
      end if
      !
    end do
    !
    if (is_NaN(R(order, order))) then
        !
        call IO_print_warning_message('Ronbint : NAN',only_rank = rank,called_by = called_by)
    end if
    !
    if (R(order, order) .ne. 0.d0) then
      !
      e = e*R(order, order)
    end if
    !
    if (present(final_order)) final_order = order
    !
    if(present(error))              error = e
    !
    Ronbint = R(order, order)

    return
  end function Ronbint

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

  function trap(y,x)

    ! ARRAY TRAPEZIUM RULE TO INTEGRATE PRE-TABULATED Y OVER X

    implicit none

    integer(kind=4)         :: i           ! index loop
    integer(kind=4)         :: n

    real(kind=4),intent(in) :: x(:),y(:)   ! x and y tables
    real(kind=8)            :: trap

    if (size(x) .ne. size(y)) then
      !
      write(*,'(a)') '!!! ERROR in trap : nx /= ny'
      stop ! stop the program
    else
      !
      n = size(x)
    end if

    trap = 0.d0    ! init
    do i = 1,n-1
       !
       trap = trap + (y(i) + y(i+1))*(x(i+1) - x(i))
    end do
    trap = trap*0.5d0

    return

  end function trap

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

  function normal_distribution(mean,sigma)

    ! Allow to give a ramdom variable following a normal distribution of mean "mean" and of standard deviation "sigma"

    implicit none

    real(kind=8),intent(in)    :: mean               ! the mean of the normal distribution
    real(kind=8),intent(in)    :: sigma              ! the standard deviation of the normal distribution
    real(kind=8)               :: normal_distribution
    real(kind=8)               :: r1,r2

    call random_number(r1)   ! get a first uniformed distributed number [0:1]
    call random_number(r2)   ! get a second uniformed distributed number [0:1]

    ! convert to normal distribution

    normal_distribution = sigma*sqrt(-2.0d0*log(r1))*cos(2.0d0*pi*r2) + mean
    return

  end function normal_distribution

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

  function erf_func(x)

    ! erf_func_x -> -1 for x-> -infinity and erf_x -> 1 for x -> +infinity

    implicit none

    real(kind=8),intent(in)   :: x        ! the argument
    real(kind=8)              :: erf_func ! the result
    real(kind=8)              :: xx

    ! Computed with the fitting formula in Lu et al 2010
    xx = x * sqrt(2.0d0)
    if (x > 0.d0) then
       !
       erf_func = 1.0d0 - ( 2.0d0 * exp(-x**2)/( 1.64*xx+sqrt(0.76*xx**2+4.0d0)) )
    else
       !
       erf_func = - 1.0d0 + ( 2.0d0 * exp(-x**2)/(-1.64*xx+sqrt(0.76*xx**2+4.0d0)) )
    endif

    return

  end function erf_func

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

  function locate2D(x,y,tab,nx,ny,xmin,ymin,dx,dy)

    ! RETURN THE VALUE STORED IN A PRE-TABULATED 2D TABLE LINKED TO INPUT PARAMETERS x AND y
    !

    implicit none

    integer(kind=4),intent(in) ::  nx,ny  ! number of data point over x and y axis respectivelly
    integer(kind=4)            ::  ix,iy  ! loop index over x and y

    real(kind=8),intent(in)    :: x,y
    real(kind=8)               :: xv, yv
    real(kind=8),intent(in)    :: tab(nx,ny)
    real(kind=8),intent(in)    :: xmin,ymin   ! minimum values over x and y respectively
    real(kind=8)               :: xmax,ymax   ! maximum values over x and y respectively
    real(kind=8),intent(in)    :: dx,dy       ! stepes over x and y respectively
    real(kind=8)               :: locate2D

    ! x
    !
    xmax = xmin+real(nx-1,8)*dx
    xv   = min(max(x,xmin),xmax)
    !
    ! y
    !
    ymax = ymin+real(ny-1,8)*dy
    yv   = min(max(y,ymin),ymax)
    !
    ix = floor((xv-xmin)/dx) +1   ! Define the x index
    iy = floor((yv-ymin)/dy) +1   ! Define the y index
    locate2D = tab(ix,iy)

    return
  end function locate2D

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

end module utilities


      SUBROUTINE DX4(U,IDMN,I,J,UXXX,UXXXX)
C
C     THIS PROGRAM COMPUTES SECOND ORDER FINITE DIFFERENCE
C     APPROXIMATIONS TO THE THIRD AND FOURTH X
C     PARTIAL DERIVATIVES OF U AT THE (I,J) MESH POINT
C
      COMMON /SPL4/   KSWX       ,KSWY       ,K          ,L          ,
     1                AIT        ,BIT        ,CIT        ,DIT        ,
     2                MIT        ,NIT        ,IS         ,MS         ,
     3                JS         ,NS         ,DLX        ,DLY        ,
     4                TDLX3      ,TDLY3      ,DLX4       ,DLY4
      DIMENSION       U(IDMN,1)
      IF (I.GT.2 .AND. I.LT.(K-1)) GO TO  50
      IF (I .EQ. 1) GO TO  10
      IF (I .EQ. 2) GO TO  30
      IF (I .EQ. K-1) GO TO  60
      IF (I .EQ. K) GO TO  80
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=A
C
   10 IF (KSWX .EQ. 1) GO TO  20
      UXXX = (-5.0*U(1,J)+18.0*U(2,J)-24.0*U(3,J)+14.0*U(4,J)-
     1                                               3.0*U(5,J))/(TDLX3)
      UXXXX = (3.0*U(1,J)-14.0*U(2,J)+26.0*U(3,J)-24.0*U(4,J)+
     1                                      11.0*U(5,J)-2.0*U(6,J))/DLX4
      RETURN
C
C     PERIODIC AT X=A
C
   20 UXXX = (-U(K-2,J)+2.0*U(K-1,J)-2.0*U(2,J)+U(3,J))/(TDLX3)
      UXXXX = (U(K-2,J)-4.0*U(K-1,J)+6.0*U(1,J)-4.0*U(2,J)+U(3,J))/DLX4
      RETURN
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=A+DLX
C
   30 IF (KSWX .EQ. 1) GO TO  40
      UXXX = (-3.0*U(1,J)+10.0*U(2,J)-12.0*U(3,J)+6.0*U(4,J)-U(5,J))/
     1       TDLX3
      UXXXX = (2.0*U(1,J)-9.0*U(2,J)+16.0*U(3,J)-14.0*U(4,J)+6.0*U(5,J)-
     1                                                      U(6,J))/DLX4
      RETURN
C
C     PERIODIC AT X=A+DLX
C
   40 UXXX = (-U(K-1,J)+2.0*U(1,J)-2.0*U(3,J)+U(4,J))/(TDLX3)
      UXXXX = (U(K-1,J)-4.0*U(1,J)+6.0*U(2,J)-4.0*U(3,J)+U(4,J))/DLX4
      RETURN
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS ON THE INTERIOR
C
   50 CONTINUE
      UXXX = (-U(I-2,J)+2.0*U(I-1,J)-2.0*U(I+1,J)+U(I+2,J))/TDLX3
      UXXXX = (U(I-2,J)-4.0*U(I-1,J)+6.0*U(I,J)-4.0*U(I+1,J)+U(I+2,J))/
     1        DLX4
      RETURN
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=B-DLX
C
   60 IF (KSWX .EQ. 1) GO TO  70
      UXXX = (U(K-4,J)-6.0*U(K-3,J)+12.0*U(K-2,J)-10.0*U(K-1,J)+
     1                                                 3.0*U(K,J))/TDLX3
      UXXXX = (-U(K-5,J)+6.0*U(K-4,J)-14.0*U(K-3,J)+16.0*U(K-2,J)-
     1                                     9.0*U(K-1,J)+2.0*U(K,J))/DLX4
      RETURN
C
C     PERIODIC AT X=B-DLX
C
   70 UXXX = (-U(K-3,J)+2.0*U(K-2,J)-2.0*U(1,J)+U(2,J))/TDLX3
      UXXXX = (U(K-3,J)-4.0*U(K-2,J)+6.0*U(K-1,J)-4.0*U(1,J)+U(2,J))/
     1        DLX4
      RETURN
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=B
C
   80 UXXX = -(3.0*U(K-4,J)-14.0*U(K-3,J)+24.0*U(K-2,J)-18.0*U(K-1,J)+
     1                                                 5.0*U(K,J))/TDLX3
      UXXXX = (-2.0*U(K-5,J)+11.0*U(K-4,J)-24.0*U(K-3,J)+26.0*U(K-2,J)-
     1                                    14.0*U(K-1,J)+3.0*U(K,J))/DLX4
      RETURN
      END


	SUBROUTINE MR_SCMZ  ( nlev, ipt, stndat, sclhgt, iret )
C************************************************************************
C* MR_SCMZ								*
C*									*
C* This subroutine computes the height to be assigned to significant	*
C* temperature levels using a moist hydrostatic computation.  The	*
C* scale heights used to compute the heights are scaled to leave the	*
C* reported mandatory level heights.					*
C*									*
C* MR_SCMZ  ( NLEV, IPT, STNDAT, SCLHGT, IRET )				*
C*									*
C* Input parameters:							*
C*	NLEV		INTEGER		Number of levels		*
C*	IPT    ( NLEV )	INTEGER		Pointers to ordered data	*
C*									*
C* Input and output parameters:						*
C*	STNDAT (6,NLEV)	REAL		Station data			*
C*									*
C* Output parameters:							*
C*	SCLHGT ( NLEV )	REAL		Scale heights			*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 9/86						*
C* M. desJardins/GSFC	 4/89	Added checks for missing data		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C
	REAL		stndat (6,*), sclhgt (*)
	INTEGER		ipt (*)
	LOGICAL		top, found, mand
C
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
	ilev = 0
	top  = .false.
C
C*	Find first level with both pressure and height data.
C
	found = .false.
	DO WHILE ( ( .not. found ) .and. ( .not. top ) )
	    ilev = ilev + 1
	    IF ( ilev .gt. nlev ) THEN
		top = .true.
	      ELSE IF ( ( .not. ERMISS ( stndat ( 1, ipt (ilev) ) ) )
     +		  .and. ( .not. ERMISS ( stndat ( 2, ipt (ilev) ) ) )
     +		  .and. ( .not. ERMISS ( stndat ( 6, ipt (ilev) ) ) ) )
     +								THEN
		found = .true.
	    END IF
	END DO
C
C*	Loop through the rest of the levels.
C
	DO WHILE  ( .not. top )
	    pb    = stndat ( 1, ipt (ilev) )
	    hb    = stndat ( 6, ipt (ilev) )
	    tb    = stndat ( 2, ipt (ilev) )
	    tdb   = stndat ( 3, ipt (ilev) )
	    plev  = stndat ( 1, ipt (ilev) )
	    zlev  = stndat ( 6, ipt (ilev) )
	    jlev = ilev
	    klev = 0
	    mand = .false.
C
C*	    Find next level with height information.
C
	    DO WHILE ( .not. mand )
		jlev = jlev + 1
		IF  ( jlev .gt. nlev ) THEN
		    mand = .true.
		    top  = .true.
		  ELSE
		    pres = stndat (1, ipt (jlev) )
		    temp = stndat (2, ipt (jlev) )
		    dwpt = stndat (3, ipt (jlev) )
		    hght = stndat (6, ipt (jlev) )
		    IF  ( ( .not. ERMISS ( hght ) ) .and.
     +			  ( .not. ERMISS ( temp ) ) )  THEN
			mand = .true.
			klev = jlev
		    END IF
C
C*		    Compute scale height to this level.
C
		    scale = PR_SCLH ( tb, temp, tdb, dwpt, pb, pres )
		    sclhgt ( ipt ( jlev ) ) = scale
C
C*		    Compute new height, but don't save it yet.
C
		    znew = PR_MHGT ( hb, pb, pres, scale )
C
C*		    Reassign variables.
C
		    IF  ( .not. ERMISS (znew) )  THEN
			tb  = temp
			tdb = dwpt
			pb  = pres
			hb  = znew
		    END IF
		END IF
	    END DO
C
C*	    If another level with height was found, recompute scale
C*	    heights to be consistent with given mandatory heights.
C
	    IF ( klev .ne. 0 ) THEN
		s = ( hght - zlev ) / ( znew - zlev )
		DO  i = ilev + 1, klev
		    sclhgt ( ipt (i) ) = sclhgt ( ipt (i) ) * s
		END DO
	    END IF
C
C*	    Compute new heights.
C
	    hbb = zlev
	    pbb = plev
	    DO  i = ilev + 1, jlev - 1
		pt    = stndat ( 1, ipt (i) )
		scale = sclhgt ( ipt (i) )
		z     = PR_MHGT ( hbb, pbb, pt, scale )
		stndat ( 6, ipt (i) ) = z
		hbb   = z
		pbb   = pt
	    END DO
C
C*	    Reset pointer to last level with height.
C
	    ilev = klev
	END DO
C*
	RETURN
	END


c rebin a spectrum from linear into log w space
c  This is a derivation from logrebin.  It does the
c  same thing but also readjusts the noise (std dev)
c  spectrum at the same time.  I just square the noise
c  to get variance and do the same additions.
c  This means adjacent bins are no longer independent,
c  but I'm not sure it's a real problem when the dominant
c  noise sources are read noise and Poisson.

c note that we ASSUME that there is a good noise value
c for every pixel where there's a good flux value.
c this could be modified but that might also cause problems.

      subroutine logrebin2(spec,nsp,espec,w0,dw,nslog,w0log,dwlog,
     $     slog,eslog)

      real spec(nsp), slog(nslog)
      real espec(nsp), eslog(nslog)
      real varspec(nsp)
      real w0,dw,w0log,dwlog
      integer nsp,nslog

      include 'pcredshift.h'

      do i=1,nspec
c         if (espec(i) .gt. bad) then
         if (spec(i) .gt. bad) then
            varspec(i) = espec(i)*espec(i)
         else
            varspec(i) = espec(i)
         end if
      end do

c      wmin = w0 + 0.5*dw
c      wmax = w0 + (nsp+0.5)*dw

c  assume that the bins of both linear and log spectra
c  are centered on the appropriate wavelength values.
c  this means throwing around a lot of 0.5's to get the
c  bin boundary values.

      do i=1,nslog
         fsum = 0.0
         wtgood = 0.0
         wtbad = 0.0
         efsum = 0.0
c  boundaries of log bin
         w1 = 10**(w0log + (i-0.5)*dwlog)
         w2 = 10**(w0log + (i+0.5)*dwlog)
c compute what lin bin the log boundaries fall in
         j1 = int( (w1-w0)/dw +0.5 )
         j2 = int( (w2-w0)/dw +0.5 )
         j1 = min(max(j1,1),nspec)
         j2 = min(max(j2,1),nspec)
         frac1 = (w1 - (w0+(j1-0.5)*dw)) / dw
         frac2 = (w2 - (w0+(j2-0.5)*dw)) / dw
c         if (j1 .ge. 1 .and. j1 .le. nsp .and. spec(j1) .gt. bad) then
         if (spec(j1) .gt. bad) then
            wtgood = wtgood + (1.-frac1)
            fsum = fsum + (1.-frac1) * spec(j1)
            efsum = efsum + (1.-frac1) * varspec(j1)
         else
            wtbad = wtbad + (1.-frac1)
         end if
         do j=j1+1,j2-1
c            if (j .ge. 1 .and. j .le. nsp .and. spec(j) .gt. bad) then
            if (spec(j) .gt. bad) then
               wtgood = wtgood + 1.
               fsum  = fsum + spec(j)
               efsum = efsum + varspec(j)
            else
               wtbad = wtbad + 1.
            end if
         end do
c         if (j2 .ge. 1 .and. j2 .le. nsp .and. spec(j2) .gt. bad) then
         if (spec(j2) .gt. bad) then
            wtgood = wtgood + frac2
            fsum = fsum + frac2 * spec(j1)
            efsum = efsum + frac2 * varspec(j1)
         else
            wtbad = wtbad + frac2
         end if
c  conserve counts (photons) so don't use the weight to normalize
c  this approach has a problem if, say, one pixel is bad
c         slog(i) = fsum
c  so rather, we estimate the flux that belonged in this bin by scaling
c  total/good
         if (wtgood .gt. 1.e-3) then
            slog(i) = fsum * (wtgood + wtbad)/wtgood
            eslog(i) = sqrt(efsum * (wtgood + wtbad)/wtgood)
         else
            slog(i) = bad
         end if

      end do

      return
      end


      real function psiinv(time,x)
c
c     + + + PURPOSE + + +
c     Computes the inverse of function PSI.  Since PSI is convex for
c     fixed time, a simple application of Newton's method will suffice
c     to invert PSI(TIME,U)=X. If time is changed by a small amount
c     between calls, the old PSIINV value provides a good starting
c     point for the next call.  Subroutine PSIS is used to compute
c     both PSI, and its derivative DPSI.  These are returned in common
c     block PSIS1.
c
c     Called from HDEPTH.
c     Author(s): Shirley, Stone
c     Reference in User Guide:
c
c     Changes:
c          1) Common block PASS not used.  It was de-referenced.
c          2) Double precison variables converted to single precision.
c          3) GOTO's changed to IF-THEN-ELSE's.
c          4) U now in common block cpsis1.inc jca2  8/31/93
c
c     Version: This module recoded from WEPP version 91.10.
c     Date recoded: 04/25/91 - 04/26/91.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
      real time, x
c
c     + + + ARGUMENT DEFINITIONS + + +
c     time   - current time
c     x      - length of equivalent plane
c
c     + + + PARAMETERS + + +
      include 'pmxtim.inc'
      include 'pmxpln.inc'
c
c     + + + COMMON BLOCKS + + +
c
      include 'cpsis1.inc'
c       read: psi,dpsi
c
      include 'cprams1.inc'
c       read: tstar
c
c     + + + LOCAL VARIABLES + + +
      real to, teco, rnd
      double precision um, ub, ut
      integer loopfg
c
c     + + + LOCAL DEFINITIONS + + +
c --- XXX Next 2 definitions unclear -- CRM 6/3/91
c     to     - lower limit of integration
c     teco   - current time or end of rainfall, whichever is less
c              (upper limit of integration)
c     rnd    - returned random number
c     ub     - beginning of integration time step
c     ut     - end of integration time step
c     um     - used in bisection method
c     loopfg - Flag. If equal '1', exit loop.
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c     psis
c     rand
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
      to = 0.0
      ub = to
      teco = min(time,tstar)
      ut = teco
      if (u.le.to.or.teco.le.u) u = (to+teco) / 2.0
c
      loopfg = 0
   10 continue
      call psis(time,u)
      if (abs(psi-x).ge.0.005*x) then
        if (dpsi.eq.0.d0) then
          call rand(rnd)
          u = ub + (ut-ub) * rnd / 2.0
        else
          um = u - (psi-x) / dpsi
          if (um.lt.u) then
            ut = u
          else
            ub = u
          end if
          if ((ut-ub).ge.0.00001d0) then
c
            if (um.le.ub) then
              u = (ub+u) / 2.0
            else if (um.lt.ut) then
              u = um
            else
              u = (ut+u) / 2.0
            end if
          else
            loopfg = 1
          end if
c
        end if
      else
        loopfg = 1
      end if
      if (loopfg.eq.0) go to 10
c
      psiinv = u
cWarning from ftnchek
c     112       psiinv = u
c     ^
cWarning near line 112 col 14: dble truncated to real
cFunction PSIINV may modify argument TIME
cFunction PSIINV modifies common variable U
c
      return
      end