!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! Thermochemistry calculation. Input:
! NAtom   : #atoms
! NAtm3   : NAtom*3
! NVib    : #vib. modes
! PGNAME  : point group symmetry symbol (without and with masses)
! AMass   : (array) atomic masses (a.m.u)
! XYZ     : (array) Cartesian coordinates (a.u.)
! Freq    : (array) vib. frequencies (a.u.) in Freq(1:NVib,IFrq), where IFrq =3 (IExpt /= 1) or 5 (IExpt == 1)
! Sc1,Sc2 : scratch. Size = NAtm3*NAtm3
! ctmp    : scratch for characters.
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine Thermochem(iinp,iout,Intact,NAtom,NAtm3,NVib,IFAtom,IExpt,PGNAME,AMass,XYZ,Freq,Sc1,Sc2,ctmp)
implicit real(kind=8) (a-h,o-z)
parameter(tolr=0.01d0)
parameter( pi       = acos(-1.0d0),                                  &
!          the parameters are taken from Gaussian09 manual
           au2ang   = 0.52917720859d0,                               &   ! a.u. (length) to Angstrom
           clight   = 2.99792458d+08,                                &   ! m/s
           planck   = 6.62606896d-34,                                &   ! Js
           avogadro = 6.02214179d+23,                                &   ! particle/mol
           boltzman = 1.38065040d-23,                                &   ! J/K
           amu2kg   = 1.660538782d-27,                               &   ! amu to kilogram
           Atm2Pa   = 1.01325d+05,                                   &   ! pressure unit: 1 atm = 101325 pa
           Cal2Jou  = 4.184d0,                                       &   ! Cal to Joule
           H2Jou    = 0.435974394d-17,                               &   ! Hartree to Joule
!          derived factors
           b2met    = au2ang*1.0d-10,                                &   ! Bohr to metre
           H2kJ     = H2Jou*avogadro*1.0d-03,                        &   ! Hartree to kJ/mol
           H2kcal   = H2kJ/Cal2Jou,                                  &   ! Hartree to kcal/mol
           Rval     = avogadro*boltzman/(1.0d3*H2kJ),                &   ! R =8.31447247 J/(K*Mol) = 3.16681476d-6 au/K
           au2wn    = sqrt(avogadro*H2Jou/1.0d1)/(2*pi*clight*b2met) )   ! au (freq) to wavenumber (=5140.4871)

real(kind=8) :: AMass(NAtom),XYZ(3,NAtom),Freq(NAtm3,*),Sc1(3,*),Sc2(*)
character*200 :: ctmp
character*4 :: PGNAME(2),PG
character*1 :: L2U
real(kind=8) :: energy(3),entropy(4)
logical :: Intact,IFAtom,IFLin,IFRdT,IfRdP

! Eel     : Total electronic energy from Q.C. calculation (a.u.)
! temp    : temperature (K)
! press   : pressure (atm)
! scale   : frequency scale factor
! PG =1   : use the point group without mass
!     2   : use the point group with mass (default)
!     xxxx: specify the name of point group, for example, D10h
namelist/Thermo/Eel,NDeg,temp,press,scale,sctol,PG
allocatable  :: freqtmp(:)

write(iout,"(//,1x,45('*'),/, ' ***   Thermal Contributions to Energies   ***',/, 1x,45('*'))")

Eel=0.d0
NDeg=1
temp=298.15d0
press=1.d0
scale=1.d0
sctol=0.d0
IFRdT=.false.
IfRdP=.false.
PG="2    "

! to rot temperatures
cf1 = planck * planck / (boltzman*8.d0*Pi*Pi*b2met*b2met*amu2kg)
! rot temperatures to rot constants (GHZ)
cf2 = 1.0d-9 * boltzman / planck
! rot temperatures to rot constants (CM^-1)
cf3 = boltzman / (planck * 1.0d2 * clight)
! temperature to Hartree
cf4 = cf3/au2wn

rewind(iinp)
read(iinp,Thermo,err=2000,end=100)

100   continue
if(temp < 0.d0)then
  IFRdT=.true.
  temp = 298.15d0
end if
if(press < 0.d0)then
  IfRdP=.true.
  press=1.d0
end if
! mass of molecule
VMas = ASum(AMass,NAtom)

if(IFAtom) then

  write(iout,"(/, &
  ' Atomic mass               :',4x,f13.6,4x,'AMU',/,    &
  ' Electronic total energy   :',4x,f13.6,4x,'Hartree' )")VMas,Eel

else
  scale=abs(scale)

  allocate(freqtmp(NVib))   ! scaled frequencies
  call ScaleF(NVib,NAtm3,IExpt,scale,sctol,Freq,freqtmp)

  ! PG = 1 or 2 (default)?
  IPG = 0
  read(PG,*,Err=300)IPG
  if(IPG < 1 .or. IPG > 2) IPG = 2
  PG = PGNAME(IPG)
  goto 310
  300  IPG = 0    ! PG is symmetry symbol
  310  continue

  if(PG == "****")PG = "C1  "
  PG(1:1)=L2U(PG(1:1))
  call charu2l(PG(2:))
  ! delete initial spaces
  PG = adjustl(PG)

! Rot. symmetry number
  call NRotSym(iout,PG,NSigma,IFLin)

  write(iout,"(/, &
  ' Molecular mass            :',4x,f13.6,4x,'AMU',/,    &
  ' Electronic total energy   :',4x,f13.6,4x,'Hartree',/,&
  ' Scaling factor of Freq.   :',4x,f13.6,/,             &
  ' Tolerance of scaling      :',4x,f13.6,4x,'cm^-1',/,  &
  ' Rotational symmetry number:',4x,i6,/,                &
  ' The ',a4,' point group is used to calculate rotational entropy.' )") VMas,Eel,scale,sctol,NSigma,PG

! calculate principal axes and moments of inertia --> Sc1(:,1:4)
  call RotCons(Intact,NAtom,AMass,XYZ,Sc1,Sc2)
  call RmNoise(12,1.0d-8,Sc1)
  write(iout,"(/, ' Principal axes and moments of inertia in atomic units:',/,37x,'1',19x,'2',19x,'3',/, &
    5x,'Eigenvalues --  ',4x,3f20.6)")Sc1(1:3,1)
  write(iout,"(11x,'X',13x,3f20.6)")(Sc1(1,i),i=2,4)
  write(iout,"(11x,'Y',13x,3f20.6)")(Sc1(2,i),i=2,4)
  write(iout,"(11x,'Z',13x,3f20.6)")(Sc1(3,i),i=2,4)

! calculate rot constants
  do i=1,3
    if(Sc1(i,1) > tolr) then
      Sc1(i,1) = cf1/Sc1(i,1)
    else
      Sc1(i,1) = 0.d0
    end if
  end do
  if(IFLin)then
    write(iout,"(/,' Rotational temperature',2x,f20.6,'    Kelvin')") Sc1(3,1)
    write(iout,"(' Rotational constant',5x,f20.6,'    cm^-1')") Sc1(3,1)*cf3
    write(iout,"(25x,f20.6,'    GHz')")Sc1(3,1)*cf2
  else
    write(iout,"(/,' Rotational temperatures',1x,3f20.6,'    Kelvin')") Sc1(1:3,1)
    write(iout,"(' Rot. constants A, B, C',2x,3f20.6,'    cm^-1')")Sc1(1:3,1)*cf3
    write(iout,"(25x,3f20.6,'    GHz')")Sc1(1:3,1)*cf2
  end if

end if

! loop of Temperature & Pressure
IRd = 0
do while(.true.)

  if(IRd > 0) then
    if(.NOT. IFRdT .and. .NOT. IFRdP)then
      exit
    else
      read(iinp,"(a200)",end=1000,err=1000)ctmp
      if(len_trim(ctmp) == 0) goto 1000
      if(IFRdT .and. IFRdP)then
        read(ctmp,*,end=1000,err=1000) temp,press
      else if(IFRdT)then
      	read(ctmp,*,end=1000,err=1000) temp
      else if(IFRdP)then
        read(ctmp,*,end=1000,err=1000) press
      end if
    end if
    if(temp < 0.d0) temp = 298.15d0
    if(press < 0.d0) press=1.d0
  end if
  IRd = IRd + 1

  write(iout,"(//,' #',i4,4x,'Temperature = ',f15.5,' Kelvin',9x,'Pressure = ',f15.5,' Atm',/, &
    1x,84('=') )") IRd,temp,press

  ! translation
  energy(1)=1.5d0*Rval*temp
  entropy(1)=boltzman*temp
  entropy(1)=(entropy(1)/(Atm2Pa*max(press,1.d-5))) * (2.d0*Pi*1.0d-3*VMas*entropy(1)/(avogadro*planck*planck))**1.5d0
  entropy(1)=Rval*(log(entropy(1))+5.d0/2.d0)

  ! rotation
  if(IFAtom)then
    energy(2)=0.d0
    entropy(2)=0.d0
  else if(IFLin)then
    energy(2)=Rval*temp
    entropy(2)=( temp/max(Sc1(3,1),1.0d-6) )/dble(NSigma)
    entropy(2)=Rval*(1.0d0 + log(entropy(2)) )
  else
    energy(2)=Rval*temp*1.5d0
    entropy(2)=Pi*temp*temp*temp/AMultip(Sc1,3,.True.,tolr/cf1)
    entropy(2)=Rval*(1.5d0 + log(sqrt(entropy(2))/dble(NSigma)) )
  end if

  ! vibration
  energy(3)=0.d0
  entropy(3)=0.d0
  do i=1,NVib
    ! at low temperature, no contributions from vibration
    if(Temp <= 10.d0) exit

    VT = freqtmp(i)/cf4
    VTT= VT/temp
    ! neglect small freq. because it leads to big errors
    if(VT <= 1.d0) cycle

    energy(3)=energy(3) + Rval * VT / (exp(VTT) - 1.d0)
    entropy(3)=entropy(3) + Rval * ( VTT/(exp(VTT) - 1.d0) - log(1.d0 - exp(-VTT)) )
  end do

  ! electronic contribution
  !energy(4) = Eel
  entropy(4)=Rval*log(dble(NDeg))
  !write(iout,"(4f22.6)")entropy*temp*H2kcal

  ! ZPE
  zpe=0.d0
  do i=1,NVib
    ! neglect imag. freq.
    if(freqtmp(i) <= 0.d0) cycle

    zpe = zpe + freqtmp(i)
  end do
  zpe=zpe*0.5d0*Rval/cf4

  ! print results
  eu=zpe+ASum(energy,3)

  eh=eu+Rval*temp
  eg=eh-temp*ASum(entropy,4)
  write(iout,"(/,                                                 &
  ' Thermal correction energies',30x,'Hartree',12x,'kcal/mol',/,  &
  ' Zero-point Energy                          :',2f20.6,/,       &
  ' Thermal correction to Energy               :',2f20.6,/,       &
  ' Thermal correction to Enthalpy             :',2f20.6,/,       &
  ' Thermal correction to Gibbs Free Energy    :',2f20.6)") zpe,zpe*H2kcal,eu,eu*H2kcal,eh,eh*H2kcal,eg,eg*H2kcal
  if(abs(Eel) > tolr)write(iout,"(/,                        &
  ' Sum of electronic and zero-point Energies  :',f20.6,/,  &
  ' Sum of electronic and thermal Energies     :',f20.6,/,  &
  ' Sum of electronic and thermal Enthalpies   :',f20.6,/,  &
  ' Sum of electronic and thermal Free Energies:',f20.6)")zpe+Eel,eu+Eel,eh+Eel,eg+Eel
  write(iout,"(1x,84('=') )")

end do

1000 continue
if(.not. IFAtom) deallocate(freqtmp)

return
2000  call XError(Intact,"Please check your input of $Thermo!")
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! calculate rot constants in cm-1
!
! Eigenvalues and Eigenvectors are saved in Sc1.
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine RotCons(Intact,NAtom,AMass,XYZ,Sc1,Sc2)
implicit real(kind=8) (a-h,o-z)
real(kind=8) :: AMass(NAtom),XYZ(3,NAtom),Sc1(*),Sc2(*)
logical :: Intact

! center of mass ---> Sc2(1:3); XYZ in CMCS --> Sc2
call MassCent(NAtom,AMass,XYZ,Sc2,Sc1)

! principal moment of inertia;
! Only 3+9+9 elements in of Sc1 will be used.
! If NAtom > 1, the size of Sc1 is large enough
IE = 1          ! Eigenvalues
IR = IE + 3     ! Eigenvectors
IW = IR + 9
call MIner(Intact,NAtom,AMass,Sc2,Sc1(IR),Sc1(IE),Sc1(IW))

return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! calculate rot. symmetry number
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine NRotSym(iout,PG,NSigma,IFLin)
implicit real(kind=8) (a-h,o-z)
character*4 :: PG,LinLib(6)
logical :: IFLin
save LinLib
data LinLib/'Dooh','D*h','Dxh','Coov','C*v','Cxv'/

IFLin = .false.
Do i=1,6
  if(index(PG,LinLib(i)) > 0) then
    IFLin = .True.
    exit
  end if
end do

! Ci, Cs
if(PG(1:2) == "Ci" .or. PG(1:2) == "Cs")then
  NSigma = 1
! Dooh
else if(IFLin .and. PG(1:1) == "D")then
  NSigma = 2
! Coov
else if(IFLin .and. PG(1:1) == "C")then
  NSigma = 1
! T, Td, Th
else if(PG(1:1) == "T")then
  NSigma = 12
! O, Oh
else if(PG(1:1) == "O")then
  NSigma = 24
! I, Ih
else if(PG(1:1) == "I")then
  NSigma = 60
! Sn (n=2m)
else if(PG(1:1) == "S")then
  NSigma = IfrmCha(4,PG)/2
! Cn, Cnv, Cnh
else if(PG(1:1) == "C")then
  NSigma = IfrmCha(4,PG)
! Dn, Dnv, Dnh
else if(PG(1:1) == "D")then
  NSigma = IfrmCha(4,PG)*2
! Unknown
else
  write(iout,"(/, ' Unknown point group ',a4,'!',/,  &
    ' SIGMA = 1 will be assumed, but it may lead to significant errors in entropy',/, ' and free energy.')")PG
  NSigma = 1
end if

if(NSigma < 1)then
  write(iout,"(/, ' Unreasonable NSigma is detected: ',i5,/,  &
    ' SIGMA = 1 will be used instead, but it may lead to significant errors in',/,  &
    ' entropy and free energy.')")NSigma
  NSigma = 1
end if

return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! Put vibrational theoretical/experimental frequencies into freqtmp. The real theoretical ones may be scaled.
!
! Freq(:,3) : theoretical frequencies
! Freq(:,5) : theoretical (and experimentally corrected if Freq(:,6) = 1.0) frequencies if IExpt = 1
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine ScaleF(NVib,NAtm3,IExpt,fscale,sctol,Freq,freqtmp)
 Implicit Real*8(A-H,O-Z)
 dimension Freq(NAtm3,*),freqtmp(*)

 if(IExpt == 1) then
   do ivib=1,NVib
     freqtmp(ivib) = Freq(ivib,5)
     if(Freq(ivib,6) < 0.0d0 .and. freqtmp(ivib) > max(sctol,0.0d0)) freqtmp(ivib) = freqtmp(ivib) * fscale
   end do
 else
   do ivib=1,NVib
     freqtmp(ivib) = Freq(ivib,3)
     if(freqtmp(ivib) > max(sctol,0.0d0)) freqtmp(ivib) = freqtmp(ivib) * fscale
   end do
 end if

 return
end

!--- END


MODULE module_chem_utilities
   USE module_domain
   USE module_model_constants
   USE module_state_description
   USE module_configure

CONTAINS
   SUBROUTINE chem_prep ( config_flags, &
                         u, v, p, pb, alt, ph, &
                         phb, t, moist, n_moist, &
                         rho, p_phy , &
                         u_phy, v_phy, p8w, t_phy, t8w, &
                         z, z_at_w, dz8w,rh, &
                         fzm, fzp, &
                         ids, ide, jds, jde, kds, kde, &
                         ims, ime, jms, jme, kms, kme, &
                         its, ite, jts, jte, kts, kte )

   IMPLICIT NONE

   TYPE(grid_config_rec_type) , INTENT(IN ) :: config_flags
   INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, &
                                       ims, ime, jms, jme, kms, kme, &
                                       its, ite, jts, jte, kts, kte
   INTEGER , INTENT(IN ) :: n_moist

   REAL, DIMENSION( ims:ime, kms:kme , jms:jme , n_moist ), INTENT(IN) :: moist

   REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , &
          INTENT( OUT) :: u_phy, &
                                                              v_phy, &
                                                              p_phy, &
                                                                p8w, &
                                                              t_phy, &
                                                                t8w, &
                                                                rho, &
                                                                  z, &
                                                               dz8w, &
                                                         rh, z_at_w

   REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , &
          INTENT(IN ) :: pb, &
                                                                  p, &
                                                                  u, &
                                                                  v, &
                                                                alt, &
                                                                 ph, &
                                                                phb, &
                                                                  t

   REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, &
                                                                fzp

   INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end
   INTEGER :: i, j, k
   REAL :: w1, w2, z0, z1, z2

    i_start = its
    i_end = min( ite,ide-1 )
    j_start = jts
    j_end = min( jte,jde-1 )

    k_start = kts
    k_end = min( kte, kde-1 )

    do j = j_start,j_end
    do k = k_start, k_end
    do i = i_start, i_end

      p_phy(i,k,j) = p(i,k,j) + pb(i,k,j)
      t_phy(i,k,j) = (t(i,k,j)+t0)*(p_phy(i,k,j)/p1000mb)**rcp
      rho(i,k,j) = 1./alt(i,k,j)*(1.+moist(i,k,j,P_QV))
      u_phy(i,k,j) = 0.5*(u(i,k,j)+u(i+1,k,j))
      v_phy(i,k,j) = 0.5*(v(i,k,j)+v(i,k,j+1))

    enddo
    enddo
    enddo

    do j = j_start,j_end
    do i = i_start, i_end
      p_phy(i,kte,j) = p_phy(i,k_end,j)
      t_phy(i,kte,j) = t_phy(i,k_end,j)
      rho(i,kte,j) = rho(i,k_end,j)
      u_phy(i,kte,j) = u_phy(i,k_end,j)
      v_phy(i,kte,j) = v_phy(i,k_end,j)
    enddo
    enddo

    do j = j_start,j_end
    do k = k_start, kte
    do i = i_start, i_end
      z_at_w(i,k,j) = (phb(i,k,j)+ph(i,k,j))/g
    enddo
    enddo
    enddo

    do j = j_start,j_end
    do k = k_start, kte-1
    do i = i_start, i_end
      dz8w(i,k,j) = z_at_w(i,k+1,j)-z_at_w(i,k,j)
    enddo
    enddo
    enddo

    do j = j_start,j_end
    do i = i_start, i_end
      dz8w(i,kte,j) = 0.
    enddo
    enddo

    do j = j_start,j_end
    do k = k_start, k_end
    do i = i_start, i_end
      z(i,k,j) = 0.5*(z_at_w(i,k,j) +z_at_w(i,k+1,j) )
      rh(i,k,j) = max(.1,MIN( .95, moist(i,k,j,p_qv) / &
               (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ &
               (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j)))))

    enddo
    enddo
    enddo

    do j = j_start,j_end
    do k = 2, k_end
    do i = i_start, i_end
      p8w(i,k,j) = fzm(k)*p_phy(i,k,j)+fzp(k)*p_phy(i,k-1,j)
      t8w(i,k,j) = fzm(k)*t_phy(i,k,j)+fzp(k)*t_phy(i,k-1,j)
    enddo
    enddo
    enddo

    do j = j_start,j_end
    do i = i_start, i_end

      z0 = z_at_w(i,1,j)
      z1 = z(i,1,j)
      z2 = z(i,2,j)
      w1 = (z0 - z2)/(z1 - z2)
      w2 = 1. - w1
      p8w(i,1,j) = w1*p_phy(i,1,j)+w2*p_phy(i,2,j)
      t8w(i,1,j) = w1*t_phy(i,1,j)+w2*t_phy(i,2,j)

      z0 = z_at_w(i,kte,j)
      z1 = z(i,k_end,j)
      z2 = z(i,k_end-1,j)
      w1 = (z0 - z2)/(z1 - z2)
      w2 = 1. - w1

      p8w(i,kde,j) = exp(w1*log(p_phy(i,kde-1,j))+w2*log(p_phy(i,kde-2,j)))
      t8w(i,kde,j) = w1*t_phy(i,kde-1,j)+w2*t_phy(i,kde-2,j)

    enddo
    enddo
END SUBROUTINE chem_prep
END MODULE module_chem_utilities


C         TEST PROGRAM FOR CORCAV SUBPROGRAM
      INCLUDE 'VICMAIN_FOR'
      SUBROUTINE MAIN44
      DOUBLE PRECISION OM(3,3),RS(3)
      CHARACTER*560 BUFFER
C==================================================================
C  DEFAULT VARIABLES FOR IO

      REQ = 1815.0
      RPOL = 1815.0
      FLAT = REQ - RPOL

C  RANDOM VALUES USED IN TEST

      IND = 0
      XL  = 0.
      YS  = 0.
      FOCL = 1500.19 * 84.821
      RS(1) = -730950.0D0
      RS(2) = -339690.0D0
      RS(3) = -1209.3D0
      OM(1,1) = 0.407057464D0
      OM(2,1) = 0.112318814D0
      OM(3,1) = 0.906470418D0
      OM(1,2) = -0.874813914D0
      OM(2,2) = -0.237469494D0
      OM(3,2) = 0.422266245D0
      OM(1,3) = 0.262687564D0
      OM(2,3) = -0.964879572D0
      OM(3,3) = 0.0015943704D0
      RLAT = -13.8018
      RLON = 360.0-150.1259
      CL = 500.0
      CS = 500.0

      CALL XVMESSAGE(' ',' ')
      CALL XVMESSAGE('LONGITUDE IS EAST ',' ')
      CALL XVMESSAGE('BEFORE CONVERSION FROM LAT/LONG TO LINE/SAMPLE:',
     .             ' ')
      WRITE(BUFFER,100)RLAT,RLON,CL,CS,IND,XL,YS,FLAG,RS,OM,FOCL,
     1            REQ,FLAT
      CALL XVMESSAGE(BUFFER(  2: 80),' ')
      CALL XVMESSAGE(BUFFER( 82:160),' ')
      CALL XVMESSAGE(BUFFER(162:240),' ')
      CALL XVMESSAGE(BUFFER(242:320),' ')
      CALL XVMESSAGE(BUFFER(322:400),' ')
      CALL XVMESSAGE(BUFFER(402:480),' ')
      CALL XVMESSAGE(BUFFER(482:560),' ')
      CALL XVMESSAGE(' ',' ')

      CALL CORCAV(IND,RLAT,RLON,OM,RS,FOCL,REQ,FLAT,XL,YS,
     1            CL,CS,FLAG)
      CALL XVMESSAGE('AFTER CONVERSION TO LINE/SAMPLE:',' ')
      CALL XVMESSAGE('LINE SHOULD BE=614.1, SAMPLE SHOULD BE 614.38',
     .               ' ')
      WRITE(BUFFER,100)RLAT,RLON,CL,CS,IND,XL,YS,FLAG,RS,OM,FOCL,
     1            REQ,FLAT
      CALL XVMESSAGE(BUFFER(  2: 80),' ')
      CALL XVMESSAGE(BUFFER( 82:160),' ')
      CALL XVMESSAGE(BUFFER(162:240),' ')
      CALL XVMESSAGE(BUFFER(242:320),' ')
      CALL XVMESSAGE(BUFFER(322:400),' ')
      CALL XVMESSAGE(BUFFER(402:480),' ')
      CALL XVMESSAGE(BUFFER(482:560),' ')
      CALL XVMESSAGE(' ',' ')
      CALL XVMESSAGE(
     . 'Repeat test case in C to test C interface: zcorcav', ' ')

      call tzcorcav( OM, RS)

      RETURN
  100 FORMAT(' RLAT:',F8.2,'E.RLON:',F8.2,4X,'CL:',E11.5,'  CS:',
     1       E11.5,17X,' IND:',I2,'  LINE:',E12.5,'  SAMPLE:',E12.5,
     2       '  FLAG:',E11.5,15X,' RS: ',3(E11.5,4X),30X,' OM:',2(
     3       3(E11.5,4X),35X),3(E11.5,4X),31X,' FOCL:',E11.5,4X,
     4       'REQ:',E11.5,4X,'FLAT:',E11.5,20X)
      END


cc Copyright (C) 2010-2011: Leslie Greengard and Zydrunas Gimbutas
cc Contact: greengard@cims.nyu.edu
c
c  Modified: (C) 2019, Leslie Greengard
cc
cc This program is free software; you can redistribute it and/or modify
cc it under the terms of the GNU General Public License as published by
cc the Free Software Foundation; either version 2 of the License, or
cc (at your option) any later version.  This program is distributed in
cc the hope that it will be useful, but WITHOUT ANY WARRANTY; without
cc even the implied warranty of MERCHANTABILITY or FITNESS FOR A
cc PARTICULAR PURPOSE.  See the GNU General Public License for more
cc details. You should have received a copy of the GNU General Public
cc License along with this program;
cc if not, see <http://www.gnu.org/licenses/>.
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c      This file contains the basic subroutines for
c      forming and evaluating multipole (partial wave) expansions
c      in two dimensions.
c
c      Remarks on scaling conventions.
c
c      1)  Hankel and Bessel functions are consistently scaled as
c       	hvec(n)= H_n(z)*rscale^(n)
c       	jvec(n)= J_n(z)/rscale^(n)
c
c          rscale should be of the order of |z| if |z| < 1. Otherwise,
c          rscale should be set to 1.
c
c      2) The potential scaling is that required of the delta function
c      response:  pot = H_0(k*r)*(eye/4)
c
c-----------------------------------------------------------------------
c
c
c
c
c
c**********************************************************************
      subroutine h2cart2polar(zat,r,theta)
      implicit none
c**********************************************************************
c
c     Convert from Cartesian to polar coordinates.
c-----------------------------------------------------------------------
c     INPUT:
c
c     zat   :  Cartesian vector
c-----------------------------------------------------------------------
c     OUTPUT:
c
c     r     :  |zat|
c     theta :  angle of (zat(1),zat(2)) subtended with
c              respect to x-axis
c-----------------------------------------------------------------------
      real *8 zat(2),r,theta
c
      r= sqrt(zat(1)**2+zat(2)**2)
      if( abs(zat(1)) .eq. 0 .and. abs(zat(2)) .eq. 0 ) then
      theta = 0
      else
      theta = datan2(zat(2),zat(1))
      endif
      return
      end
c
c
c
c**********************************************************************
      subroutine h2dall(nterms,z,rscale,hvec,ifder,hder)
      implicit none
c**********************************************************************
c
c     This subroutine computes scaled versions of the Hankel
c     functions H_n of orders 0 to nterms.
c
c       	hvec(n)= H_n(z)*rscale^(n)
c
c     The parameter SCALE is useful when |z| < 1, in which case
c     it damps out the rapid growth of H_n as n increases. In such
c     cases, we recommend setting
c
c               rscale approx |z|
c
c     or something close. If |z| > 1, set scale = 1.
c
c     If the flag IFDER is set to one, it also computes the
c     derivatives of h_n.
c
c		hder(n)= H_n'(z)*rscale^(n)
c
c     NOTE: If |z| < 1.0d-200, the subroutine returns zero.
c
c-----------------------------------------------------------------------
c     INPUT:
c
c     nterms :  highest order of the Hankel functions to be computed.
c     z      :  argument of the Hankel functions.
c     rscale :  scaling parameter discussed above
c     ifder  :  1 => compute hder array, otherwise do not
c-----------------------------------------------------------------------
c     OUTPUT:
c
c     hvec   :  the vector of Hankel functions
c     hder   :  the derivatives of the Hankel functions
c-----------------------------------------------------------------------
      integer i,ifexpon,ifder,nterms
      real *8 thresh,done,rscale,scal2,dtmp
      complex *16 hvec(0:*),hder(0:*)
      complex *16 zk2,z,zinv,ztmp,fhextra,h0,h1
c
      data thresh/1.0d-200/,done/1.0d0/
c
c     If |z| < thresh, return zeros.
c
      if (abs(z).lt.thresh) then
         do i=0,nterms
            hvec(i)=0
            hder(i)=0
         enddo
         return
      endif
c
c     Otherwise, get H_0 and H_1 via hank103 and the rest via
c     recursion.
c
      ifexpon=1
      call hank103(z,h0,h1,ifexpon)
      hvec(0)=h0
      hvec(1)=h1*rscale
c
c
c     From Abramowitz and Stegun (9.1.27)
c
c       H_{n-1}(z) + H_{n+1}(z) = 2*n/z * H_n(z)
c
c     With scaling:
c
c       H_{n-1}(z) *rscale + H_{n+1}(z)/rscale = 2*n/z * H_n(z)
c       H_{n+1}(z) = rscale*(2*n/z*H_n(z) - H_{n-1}(z)*rscale)
c
      scal2=rscale*rscale
      zinv=rscale/z
      do i=1,nterms-1
         dtmp=2*i
         ztmp=zinv*dtmp
         hvec(i+1)=ztmp*hvec(i)-scal2*hvec(i-1)
      enddo
c
c
c     From Abramowitz and Stegun (9.1.27)
c
c     H_{n}'(z)= H_{n-1}(z) - (n)/z * H_n(z)
c
c     With scaling:
c
c     hder(n)=scale* hvec(n-1) - n/z * hvec(n)
c
      if (ifder.eq.1) then
c
         hder(0)=-hvec(1)/rscale
         zinv=1.0d0/z
         do i=1,nterms
            dtmp=(i)
            ztmp=zinv*dtmp
            hder(i)=rscale*hvec(i-1)-ztmp*hvec(i)
         enddo
c
      endif
c
      return
      end
c
c
c
c
c
C***********************************************************************
      subroutine h2dmpzero(nd,mpole,nterms)
      implicit none
C***********************************************************************
c
c     This subroutine sets a multipole expansion to zero.
c-----------------------------------------------------------------------
c     INPUT:
c
c     nd     :   number of expansions
c     nterms :   order of multipole expansion
C---------------------------------------------------------------------
c     OUTPUT:
c
c     mpole  :   coeffs for the expansion set to zero.
C---------------------------------------------------------------------
      integer n,nterms,nd,idim
      complex *16 mpole(nd,-nterms:nterms)
c
      do n=-nterms,nterms
        do idim=1,nd
          mpole(idim,n)=0.0d0
        enddo
      enddo
      return
      end
c
c


      FUNCTION fredin(x,n,a,b,t,f,w,g,ak)
      INTEGER n
      REAL fredin,a,b,x,f(n),t(n),w(n),g,ak
      EXTERNAL ak,g
CU    USES ak,g
      INTEGER i
      REAL sum
      sum=0.
      do 11 i=1,n
        sum=sum+ak(x,t(i))*w(i)*f(i)
11    continue
      fredin=g(x)+sum
      return
      END

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


      subroutine SSFIND ( XT, IX1, IX2, X, LEFTI, MODE )
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 SSFIND Krogh Removed Fortran 90 comment.
c>> 1994-11-11 CLL Replaced Fortran 90 DO WHILE's with GOTO's for F77.
c>> 1994-10-20 SSFIND Krogh  Changes to use M77CON
c>> 1992-11-12 SSFIND C. L. Lawson, JPL
c>> 1992-10-23 C. L. Lawson, JPL
c>> 1988-03-16 C. L. Lawson, JPL
c
c     Require IX1 < IX2.
c     Require the values in XT() indexed from IX1 to IX2 to be
c     nondecreasing.
c     Require XT(IX1)   < XT(IX1+1).
c     Require XT(IX2-1) < XT(IX2).
c     Let A = XT(IX1) and B = XT(IX2).
c     The closed interval, [A, B], is regarded as being partitioned
c     partitioned into IX2-IX1 disjoint subintervals, with all but the
c     last being half-open, and the last one being closed:
c        [XT(I), XT(I+1)), I = IX1, ..., IX2-2
c        [XT(IX2-1), XT(IX2)]
c     Some of these intervals may have zero length, but not the first
c     and last ones.
c     This subroutine identifies the location of X with respect to these
c     subintervals by setting LEFTI and MODE as follows:
c     If X is contained in one of these segments of nonzero length,
c     set MODE = 0 and set LEFTI to be the index of the left end of the
c     segment containing X.  Thus LEFTI will satisfy
c     IX1 .le. LEFTI .le. IX2-1.
c     If X < A, set MODE = -1 and LEFTI = IX1.
c     If X > B, set MODE = +1 and LEFTI = IX2-1.
c     Issue an error message and stop if
c        X < XT(IX1+1) and XT(IX1) .ge. XT(IX1+1)  or if
c        X .ge. XT(IX2-1) and XT(IX2-1) .ge. XT(IX2)
c     ------------------------------------------------------------------
c                              Method
c
c        Saves the value of LEFTI returned on previous call in ILO.
c     Starts by checking to see if X is in this same segment.
c     If so, finishes quickly.  We assume this will be a frequently
c     occurring case.
c     If not, searches either to the left or right from this previous
c     segment, as appropriate.  During this search the stride is doubled
c     until a bracketing value is found.  Then we finish with a binary
c     search between the bracketing points.
c     ------------------------------------------------------------------
c     Based on subroutine INTERV on pp. 92-93 of A PRACTICAL GUIDE TO
c     SPLINES by Carl De Boor, Springer-Verlag, 1978.
c     Current version by C. L. Lawson, JPL, March 1988.
c     ------------------------------------------------------------------
C  XT()  [in]  This subr will access XT(i) for i = IX1, ..., IX2.  These
c        values must be nondecreasing.  Repeated values are permitted
c        except for the first two and last two.
c  IX1, IX2   [in]  Indices specifying the portion of the array XT() to
c        be considered by this subr.  Require IX1 < IX2.
c  X     [in]  Value to be looked up.
c  LEFTI [inout]  On entry LEFTI must contain an integer value.  If it
c       in the range [IX1, IX2-1] the search will start with this index.
c       Otherwise the search will start with IX1 or IX2-1.
c       On return LEFTI will be in [IX1, IX2-1], and identifies
c       the interval (of nonzero length) from X(LEFTI) to
c       X(LEFTI+1) as the reference subinterval for X.
c       LEFTI = IX1 means X < XT(IX1+1)
c       IX1 < LEFTI < IX2-1 means XT(LEFTI) .le. X .lt. XT(LEFTI+1)
c       LEFTI = IX2-1 means XT(IX2-1) .le. X
c  MODE [out]  Set to
c        -1 if X < XT(IX1)
c         0 if     XT(IX1) .le. X .le. XT(IX2)
c        +1 if                         XT(IX2) < X
c     ------------------------------------------------------------------
c--S replaces "?": ?SFIND, ?ERV1
c     Both use IERM1
c     ------------------------------------------------------------------
      integer IHI, ILO, LEFTI, IX1, IX2, MIDDLE, MODE, STEP
      real             X,  XT(1:IX2)
c     ------------------------------------------------------------------
      ILO = max(IX1, min(LEFTI, IX2-1))
      if(X .ge. XT(ILO))then
         if(X .lt. XT(ILO+1))then
            MODE = 0
            LEFTI = ILO
            return
         else
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c     procedure( SEARCH TO RIGHT )

      STEP = 1
      IHI = ILO + 1
*     do while(.true.)              !  Using Fortran 90 "DO" syntax.
    5 continue
         if(IHI .eq. IX2) then
c                                            Here X .ge. XT(IX2)
            if(X .eq. XT(IX2)) then
               MODE = 0
            else
               MODE = +1
            endif
            ILO  = IX2-1
            LEFTI = ILO
            if(XT(ILO) .ge. XT(IX2)) then
               call IERM1('SSFIND',2,2,'Require T(IX2-1) < T(IX2)',
     *         'IX2',IX2,',')
               call SERV1('T(IX2-1)',XT(IX2-1),',')
               call SERV1('T(IX2)',  XT(IX2),  '.')
            endif
            return
         endif
         ILO = IHI
         IHI = min(IHI + STEP, IX2)
         if(X .lt. XT(IHI)) go to 10
         STEP = 2.0e0 * STEP
      go to 5
*     end do !while
   10 continue
c     end proc !( SEARCH TO RIGHT )
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
         endif
      else
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c     procedure( SEARCH TO LEFT )

      STEP = 1
*     do while(.true.)
   15 continue
         if(ILO .eq. IX1) then
            MODE = -1
            LEFTI = IX1
            if(XT(IX1) .ge. XT(IX1+1)) then
               call IERM1('SSFIND',1,2,'Require T(IX1) < T(IX1+1)',
     *         'IX1',IX1,',')
               call SERV1('T(IX1)',  XT(IX1),  ',')
               call SERV1('T(IX1+1)',XT(IX1+1),'.')
            endif
            return
         endif
         IHI = ILO
         ILO = max(ILO - STEP, IX1)
         if(X .ge. XT(ILO)) go to 20
         STEP = 2.0e0 * STEP
      go to 15
*     end do !while
   20 continue
c     end proc !( SEARCH TO LEFT )
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      endif
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c     procedure( BINARY SEARCH )

c                   Here XT(ILO) .le. X .lt. XT(IHI)
c
*     do while(.true.)
   25 continue
         MIDDLE = (ILO + IHI)/2
         if (MIDDLE .eq. ILO) go to 30
         if (X .ge. XT(MIDDLE)) then
            ILO = MIDDLE
         else
            IHI = MIDDLE
         endif
      go to 25
*     end do !while
   30 continue
      MODE = 0
      LEFTI = ILO
c     end proc !( BINARY SEARCH )
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      return
      end


! { dg-do compile }
! { dg-options "-O3" }
function pr52701 (x, z, e, f, g, l)
  integer a, b, c, d, e, f, g, i, j, l, pr52701
  double precision x(e), z(e*e)
  do i = l, f
    do j = l, i
      d = 0
      do a = 1, g
        c = a - g
        do b = 1, g
          d = d + 1
          c = c + g
          z(d) = z(d) / (x(i) + x(j) - x(f + a) - x(f + b))
        end do
      end do
    end do
  end do
  pr52701 = c
end


      program p
      real a(10,10,10,10,10)
      do m=2,5
         do l=5,7
            do k=1, 2
               do j=1, 2
                  do i=1, 10
                     x = 2.3
                     y=5.3 + x
                     z=2.32 + y
                     w=1.2 + z
                     a(i,j,k,l,m) = x*x+x+z
                  enddo
               enddo
            enddo
         enddo
      enddo
      end


** Copyright (c) 1989, NVIDIA CORPORATION.  All rights reserved.
**
** Licensed under the Apache License, Version 2.0 (the "License");
** you may not use this file except in compliance with the License.
** You may obtain a copy of the License at
**
**     http://www.apache.org/licenses/LICENSE-2.0
**
** Unless required by applicable law or agreed to in writing, software
** distributed under the License is distributed on an "AS IS" BASIS,
** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
** See the License for the specific language governing permissions and
** limitations under the License.

*   Constant folding of relational operators (EQ, NE, GT, GE,
*   LE, LT) for numeric types, character, and logical.
*   Constant expressions requiring type conversion of one of
*   the arguments are not tested.

	parameter (N = 36)
	implicit logical(F, l-W)
	dimension rslts(N)
	integer expect(N)

	parameter(p1 = 2 .eq.2, p2 = 3 .gt. 4)
	parameter(p3 = 2.0 .eq. 2.01, p4 = 3.1.ge.3.0)
	parameter(p5 = 5.0D1.ne.5.0D1, p6=5.0D0.lt.5.0d1)
	parameter(p7=(1.0,1.0).eq.(1.0,1.0), p8=(1.0,1.0).eq.(1.0,0.0))
	parameter(p9 = 'ab' .ne. 'ab', p10 = 'ab' .eq. 'ab ')
	parameter(p11 = .true..eq..true., p12 = .true..ne..false.)
	parameter(TRUE = -1)

	data expect / TRUE, 0, TRUE, 0, TRUE, 0, TRUE, TRUE,
     +                0, TRUE, 0, 0, TRUE, TRUE,
     +                0, TRUE, 0, 0, 0, 0,
     +                TRUE, 0, 0, TRUE,
     +                0, TRUE, 0, TRUE, 0, 0, TRUE, TRUE,
     +                TRUE, TRUE, 0, 0               /

C  --- tests 1 - 8:     integer comparisons.

	rslts(1) = p1
	rslts(2) = p2
	rslts(3) = 4 .ge. 3
	rslts(4) = '4'x .le. '3'x
	rslts(5) = 3 .ne. -3
	rslts(6) = 3 .lt. -3
	rslts(7) = -1.lt.0
	rslts(8) = 99999.ge.99999

C  --- tests 9 - 14:    real comparisons.

	rslts(9) = p3
	rslts(10) = p4
	rslts(11) = 5.23 .lt. 5.23
	rslts(12) = -2.5 .ne. -2.5
	rslts(13) = 2.5 .gt. 0.0
	rslts(14) = -.1. le .0.0

C  --- tests 15 - 20:   double precision comparisons.

	rslts(15) = p5
	rslts(16) = p6
	rslts(17) = 2.5D0 .eq. 2.5D-1
	rslts(18) = -1.0D0 .ge. 0.0D0
	rslts(19) = -2.1D-11.gt.-2.1D-11
	rslts(20) = 2.5d0 .le. -2.5d0

C  --- tests 21 - 24:   complex comparisons (only EQ, NE allowed).

	rslts(21) = p7
	rslts(22) = p8
	rslts(23) = (1.0, 0.0) .ne. (1.0, 0.0)
	rslts(24) = (1.0, 0.0) .ne. (1.0, 1.0)

C  --- tests 25 - 32:   character comparisons.

	rslts(25) = p9
	rslts(26) = p10
	rslts(27) = 'a'.gt.'b'
	rslts(28) = 'ab ' .le. 'ab'
	rslts(29) = 'abb' .ge. 'abc'
	rslts(30) = 'ab' .lt. 'a'
	rslts(31) = 'abdd' .gt. 'abcd  '
	rslts(32) = 'abcdef' .lt. 'abcdef!'

C  --- tests 33 - 36:   logical comparisons, EQ and NE (extension to
C                       f77 standard).

	rslts(33) = p11
	rslts(34) = p12
	rslts(35) = .false. .eq. .true.
	rslts(36) = .false. .ne. .false.

C  --- check results:

	call check(rslts, expect, N)
	end


!Los arreglos pueden almacenar un tamaño fijo de una colección secuencial de elementos del mismo tipo. Un arreglo es usado para almacenar una
!colección de datos, pero es más útil pensar de ellos como una colección de variables del mismo tipo.

!Todos los arreglos consisten de locaciones en memoria continuas. La dirección de memoria más baja corresponde al primer elemenento
!y la mas alta al último.

!Los arreglos pueden ser unidimensionales (vectores), bidimensionales (arreglos). Fortran soporta hasta 7 dimensiones.

program tam_fijo
!Para declarar un arreglo se utiliza los atributos de dimension
real, dimension(5) :: arreglo_1

!Otra forma de declarar un arreglo unidimensional es utilizando la siguiente sintaxis:
real, dimension(-1:3) :: arreglo_2 = (/1, 2, 3, 4, 5/)

!Si queremos crear un arreglo bidimensional o una matriz, hariamos la siguiente declaración:
integer, dimension (5,5) :: matriz

!Si queremos declarar un arreglo con un limite inferior, lo podemos hacer de manera explicita:
integer, dimension(0:4) :: arreglo_3
!Con esto declaramos un arreglo que inicia en el idice 0 y termina en el 4

!Y de igual manera con los arreglos de dimensiones superiores:
integer, dimension(0:4, 1:6) :: matriz_2
! En este caso, declaramos una matriz tal que los indices del primer arreglo contiene 5 elementos comenzando sus
! indices en 0 hasta el 4 y cada uno de estos elementos del arreglo contiene un arreglo de integers con 6 elementos de
! tal manera que si lo fueramos a ilustrar de manera gráfica tendíamos algo similar a esto:

!indice: 0  1  2  3  4
!1      [ ][ ][ ][ ][ ]
!2		[ ][ ][ ][ ][ ]
!3		[ ][ ][ ][ ][ ]
!4		[ ][ ][ ][ ][ ]
!5		[ ][ ][ ][ ][ ]
!6		[ ][ ][ ][ ][ ]

integer, dimension(4,4):: matriz_3

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

!Para acceder a los elementos de un arreglo simplemente llamamos al arreglo y especificamos su indice con paréntesis:

!Recordemos que arreglo_1 contiene 5 números reales y va desde (1 ≤ i ≤ 5).
!Estos números pueden ser accedidos utilizando sus indices comenzando desde el 1 entonces.

print *, "Posición 1 de arreglo_1: ", arreglo_1(1)
print *, "Posición (2, 6) de matriz_2: ", matriz_2(2, 6)

!Además, Fortran nos permite acceder a diversos elementos utilizando sólo una sentencia.
!Para acceder a una sección del arreglo, es necesario proveer de los límites inferior y superior asi como un incremento
!para todas las dimensiones

!A esto se le llama "Subscript Triplets" o Triplete de Subindices:
!		array ([lower]:[upper][:stride], ...)
!donde lower es el límite inferior está dado por el parámetro lower; El superior upper y el incremento stride

print *, "matriz_2(1:4:1): ", matriz_3(1:4:1, 1:4:1)
!Recorremos del intervalo 1 al 4 de 1 en 1 para la dimensión 1 y para la dimensión 2

print *, "matriz_2(1:4:1): ", matriz_3(1:4:1, 3:1:-1)
!Recorremos en sentido inverso ahora la dimensión 2 desde 3 a 1

end program tam_fijo


      program callabsval

c     bug: results are better in absval than in callabsval because
c     the absval transformer does not take the test condition into account

c     note also that preconditions in the test branches are not symmetrical
c     because 0 belongs to the [-1..1] interval and because the condition
c     .lt. is more precise when n is negative

      i = 1
      call absval(i, iabs)
      i = -1
      call absval(i, iabs)
      print *, i, iabs
      end
      subroutine absval(n, nabs)
      if(n.lt.0) then
         nabs = -n
      else
         nabs = n
      endif
      end


! { dg-do compile }
! { dg-additional-options "-O -Wfrontend-loop-interchange" }
PROGRAM TEST_DO_SPEED
  IMPLICIT NONE

  REAL, ALLOCATABLE :: A(:,:,:), B(:,:,:), C(:,:,:)
  REAL :: TIC
  INTEGER :: T0, T1, T2
  INTEGER :: I, J, K
  INTEGER, PARAMETER :: L = 512, M = 512, N = 512

  ALLOCATE( A(L,M,N), B(L,M,N), C(L,M,N) )
  CALL RANDOM_NUMBER(A)
  CALL RANDOM_NUMBER(B)

  CALL SYSTEM_CLOCK( T0, TIC)

  DO CONCURRENT( K=1:N, J=1:M, I=1:L) ! { dg-warning "Interchanging loops" }
    C(I,J,K) = A(I,J,K) +B(I,J,K)
  END DO
END


!-----------------------------------------------------------------------------
!
! QSORT
!
! Quicksort
!
!-----------------------------------------------------------------------------

  subroutine qsort(n,arr,brr)

  integer(kind=4) n,M,NSTACK
  real(kind=8) arr(n)
  real(kind=4) brr(n)
  parameter (M=7,NSTACK=50)

! Sorts an array arr(1:n) into ascending order using Quicksort, while
! making corresponding rearrangement of the array brr(1:n).

  integer(kind=4) i,ir,j,jstack,k,l,istack(NSTACK)
  real(kind=8) a,b,temp
  jstack=0
  l=1
  ir=n

! Insertion sort when subarray small enough.

1 if (ir-l.lt.M) then
     do j=l+1,ir
        a=arr(j)
        b=brr(j)
        do i=j-1,1,-1
           if (arr(i).le.a) goto 2
           arr(i+1)=arr(i)
           brr(i+1)=brr(i)
        end do
        i=0
2       arr(i+1)=a
        brr(i+1)=b
     end do
     if (jstack.eq.0) return
     ir=istack(jstack) ! Pop stack and begin a new round of partiti
     l=istack(jstack-1)
     jstack=jstack-2
  else

! Choose median on left, center and right elements as partitioning eleme
! Also rearrange so that a(l+1) .leq. a(l) .leq. a(ir).

     k=(l+ir)/2
     temp=arr(k)
     arr(k)=arr(l+1)
     arr(l+1)=temp
     temp=brr(k)
     brr(k)=brr(l+1)
     brr(l+1)=temp
     if (arr(l+1).gt.arr(ir)) then
        temp=arr(l+1)
        arr(l+1)=arr(ir)
        arr(ir)=temp
        temp=brr(l+1)
        brr(l+1)=brr(ir)
        brr(ir)=temp
     end if
     if (arr(l).gt.arr(ir)) then
        temp=arr(l)
        arr(l)=arr(ir)
        arr(ir)=temp
        temp=brr(l)
        brr(l)=brr(ir)
        brr(ir)=temp
     end if
     if (arr(l+1).gt.arr(l)) then
        temp=arr(l+1)
        arr(l+1)=arr(l)
        arr(l)=temp
        temp=brr(l+1)
        brr(l+1)=brr(l)
        brr(l)=temp
     end if

! Initialize pointers for partitioning.

     i=l+1
     j=ir
     a=arr(l) ! Partitioning element.
     b=brr(l)
3    continue ! Beginning of innermost loop.
     i=i+1 ! Scan up to find element .gt. a.
     if (arr(i).lt.a) goto 3
4    continue
     j=j-1 ! Scan down to find element .lt. a.
     if (arr(j).gt.a) goto 4
     if (j.lt.i) goto 5 ! Pointers crossed. Partitioning complete.
     temp=arr(i) ! Exchange elements of both arrays.
     arr(i)=arr(j)
     arr(j)=temp
     temp=brr(i)
     brr(i)=brr(j)
     brr(j)=temp
     goto 3 ! End of the innermost loop.
5    arr(l)=arr(j) ! Insert partitioning element in both arrays.
     arr(j)=a
     brr(l)=brr(j)
     brr(j)=b
     jstack=jstack+2

! Push pointers to larger subarray on stack, process smaller subarray
! immediately.

     if (jstack.gt.NSTACK) then
        write(6,*) 'NSTACK too small!'
        stop
     end if
     if (ir-i+1.ge.j-l) then
        istack(jstack)=ir
        istack(jstack-1)=i
        ir=j-1
     else
        istack(jstack)=j-1
        istack(jstack-1)=l
        l=i
     end if
  end if
  goto 1

  end subroutine qsort


module mod_rgrd1u
    implicit none

contains
    !

    ! Code converted using TO_F90 by Alan Miller
    ! Date: 2013-09-18  Time: 12:22:50

    ! ... file rgrd1u.f

    !     this file contains documentation followed by fortran code for
    !     subroutine rgrd1u and additional subroutines.

    ! ... author

    !     John C. Adams (NCAR 1999)

    ! ... subroutine rgrd1u(nx,p,mx,q,intpol,w,lw,iw,liw,ier)

    ! ... purpose

    !     subroutine rgrd1u interpolates the nx vector p onto
    !     the mx vector q. it is assumed that p and q are
    !     values on uniform nx and mx grids which subdivide
    !     the same interval (INCLUDING END POINTS).  if p and
    !     q are values on nonuniform grids and/or if q is defined
    !     on a grid which lies within the p grid then subroutine
    !     rgrd1 (see file rgrd1.f) should be used.

    ! ... language

    !     coded in portable FORTRAN77 and FORTRAN90

    ! ... test program

    !     file trgrd1u.f on regridpack includes a test program for subroutine rgrd1u

    ! ... method

    !     linear or cubic interpolation (see intpol) is used when the
    !     mx uniform grid is not a subgrid of the nx uniform grid (i.e.,
    !     whenever mx-1 does not divide nx-1).  q is set directly from
    !     p in the subgrid case.

    ! ... required files

    !     none

    ! ... efficiency

    !     inner most loops in regridpack software vectorize.

    ! *** input arguments ***

    ! ... nx

    !     the integer dimension of p.  nx > 1 if intpol = 1 or
    !     nx > 3 if intpol = 3 is required (see ier = 2).

    ! ... p

    !     a real (kind=8) nx dimensioned vector of given values

    ! ... mx

    !     the integer dimension of q.  mx > 1 is required (see ier = 1)

    ! ... intpol

    !     an integer which sets linear or cubic interpolation as follows:

    !        intpol = 1 sets linear interpolation
    !        intpol = 3 sets cubic interpolation

    !     values other than 1 or 3 in intpol are not allowed (ier = 4).

    ! ... w

    !     a real (kind=8) work space of length lw.

    ! ... lw

    !     the integer length of the work space w in the routine calling rgrd1u.
    !     if mx-1 divides nx-1 then the mx uniform grid is a subgrid of
    !     the nx uniform grid.  in this case let lwmin = 1.  otherwise
    !     let lwmin = mx if intpol = 1 or lwmin = mx if intpol = 3.
    !     then lw must be greater than or equal to lwmin (see ier=4).

    ! ... iw

    !     an integer work space of length liw

    ! ... liw

    !     the integer length of the integer work space iw in the routine calling rgrd1u.
    !     liw must be greater than or equal to mx.

    ! *** output arguments ***

    ! ... q

    !     a real (kind=8) mx dimensioned vector of values which are interpolated from p.

    ! ... ier

    !     an integer error flag set as follows:

    !     ier = 0 if no errors in input arguments are detected

    !     ier = 1 if  mx < 2

    !     ier = 2 if nx < 2 when intpol=1 or nx < 4 when intpol=3.

    !     ier = 3 if intpol is not equal to 1 or 3

    !     ier = 4 if lw or liw is too small (insufficient work space)

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

    !     end of rgrd1u documentation, fortran code follows:

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

    SUBROUTINE rgrd1u(nx,p,mx,q,intpol,w,lw,iw,liw,ier)

    IMPLICIT NONE
    INTEGER, INTENT(IN)                      :: nx
    real (kind=8), INTENT(IN)                :: p(nx)
    INTEGER, INTENT(IN)                      :: mx
    real (kind=8), INTENT(OUT)               :: q(mx)
    INTEGER, INTENT(IN)                      :: intpol
    real (kind=8), INTENT(INOUT)             :: w(lw)
    INTEGER, INTENT(IN)                      :: lw
    INTEGER, INTENT(INOUT)                   :: iw(liw)
    INTEGER, INTENT(IN)                      :: liw
    INTEGER, INTENT(OUT)                     :: ier
    INTEGER :: inmx,isubx
    INTEGER :: i2,i3,i4,i5,lwmin

    !     check input arguments

    ier = 1

    !     check mx

    IF (mx < 2) RETURN

    !     check intpol

    ier = 3
    IF (intpol /= 1 .AND. intpol /= 3) RETURN

    !     check nx

    ier = 2
    IF (intpol == 1 .AND. nx < 2) RETURN
    IF (intpol == 3 .AND. nx < 4) RETURN

    !     set subgrid integer indicator

    inmx = (nx-1)/(mx-1)
    isubx = nx - inmx*(mx-1)

    !     set minimum and check work space

    ier = 4
    IF (isubx /= 1) THEN
      IF (intpol == 1) lwmin = mx
      IF (intpol == 3) lwmin = 4*mx
    ELSE
      lwmin = 1
    END IF
    IF (lw < lwmin) RETURN
    IF (liw < mx) RETURN

    !     input arguments o.k.

    ier = 0

    !     preset pointers

    i2 = 1
    i3 = 1
    i4 = 1
    i5 = 1
    IF (intpol == 1) THEN

    !     linear interpolation in x

      IF (isubx /= 1) THEN
        CALL linmxu(nx,mx,iw,w)
      END IF
      CALL lint1u(nx,p,mx,q,iw,w,inmx,isubx)
      RETURN
    ELSE

    !     cubic interpolation in x

      IF (isubx /= 1) THEN
        i2 = 1
        i3 = i2+mx
        i4 = i3+mx
        i5 = i4+mx
        CALL cubnmxu(nx,mx,iw,w(i2),w(i3),w(i4),w(i5))
      END IF
      CALL cubt1u(nx,p,mx,q,iw,w(i2),w(i3),w(i4),w(i5),inmx,isubx)
      RETURN
    END IF
    END SUBROUTINE rgrd1u

    SUBROUTINE lint1u(nx,p,mx,q,ix,dx,inmx,isubx)

    IMPLICIT NONE
    INTEGER, INTENT(IN)                      :: nx
    real (kind=8), INTENT(IN)                :: p(nx)
    INTEGER, INTENT(IN)                      :: mx
    real (kind=8), INTENT(OUT)               :: q(mx)
    INTEGER, INTENT(IN)                      :: ix(mx)
    real (kind=8), INTENT(IN)                :: dx(mx)
    INTEGER, INTENT(IN)                      :: inmx
    INTEGER, INTENT(IN)                      :: isubx
    INTEGER :: i,ii

    IF (isubx == 1) THEN

    !     mx grid is subset of nx grid so q can be set directly

      DO ii=1,mx
        i = inmx*(ii-1)+1
        q(ii) = p(i)
      END DO
      RETURN
    ELSE

    !     linearly interpolate

      DO ii=1,mx
        i = ix(ii)
        q(ii) = p(i)+dx(ii)*(p(i+1)-p(i))
      END DO
      RETURN
    END IF
    END SUBROUTINE lint1u

    SUBROUTINE cubt1u(nx,p,mx,q,ix,dxm,dx,dxp,dxpp,inmx,isubx)

    IMPLICIT NONE
    INTEGER, INTENT(IN)                      :: nx
    real (kind=8), INTENT(IN)                :: p(nx)
    INTEGER, INTENT(IN)                      :: mx
    real (kind=8), INTENT(OUT)               :: q(mx)
    INTEGER, INTENT(IN)                      :: ix(mx)
    real (kind=8), INTENT(IN OUT)            :: dxm(mx)
    real (kind=8), INTENT(IN)                :: dx(mx)
    real (kind=8), INTENT(IN)                :: dxp(mx)
    real (kind=8), INTENT(IN OUT)            :: dxpp(mx)
    INTEGER, INTENT(IN)                      :: inmx
    INTEGER, INTENT(IN)                      :: isubx
    INTEGER :: i,ii

    IF (isubx == 1) THEN

    !     mx grid is subset of nx grid so q can be set directly

      DO ii=1,mx
        i = inmx*(ii-1)+1
        q(ii) = p(i)
      END DO
      RETURN

    ELSE

    !     cubically interpolate on uniform grid

      DO ii=1,mx
        i = ix(ii)
        q(ii)=(dxm(ii)*p(i-1)+dx(ii)*p(i)+dxp(ii)*p(i+1)+ dxpp(ii)*p(i+2))
      END DO
      RETURN
    END IF
    END SUBROUTINE cubt1u

    SUBROUTINE linmxu(nx,mx,ix,dx)

    !     set linear interpolation terms

    IMPLICIT NONE
    INTEGER, INTENT(IN)                      :: nx
    INTEGER, INTENT(IN)                      :: mx
    INTEGER, INTENT(OUT)                     :: ix(mx)
    real (kind=8), INTENT(OUT)               :: dx(mx)
    INTEGER :: i,ii
    real (kind=8) :: dnx,dmx,x,xx

    !     set "virtual" uniform increments

    dnx = 1.0/(nx-1)
    dmx = 1.0/(mx-1)

    !     set ix(ii) = i  s.t. i,i+1 can interpolate for ii

    DO ii=1,mx
      xx = (ii-1)*dmx
      ix(ii) = MIN0(INT(xx/dnx)+1,nx-1)

    !     set scale term for linear

      i = ix(ii)
      x = (i-1)*dnx
      dx(ii) = (xx-x)/dnx
    END DO
    RETURN
    END SUBROUTINE linmxu

    SUBROUTINE cubnmxu(nx,mx,ix,dxm,dx,dxp,dxpp)

    !     set cubic interpolation terms

    IMPLICIT NONE
    INTEGER, INTENT(IN)                      :: nx
    INTEGER, INTENT(IN)                      :: mx
    INTEGER, INTENT(OUT)                     :: ix(mx)
    real (kind=8), INTENT(OUT)               :: dxm(mx)
    real (kind=8), INTENT(OUT)               :: dx(mx)
    real (kind=8), INTENT(OUT)               :: dxp(mx)
    real (kind=8), INTENT(OUT)               :: dxpp(mx)
    INTEGER :: i,ii
    real (kind=8) :: dnx,dmx,odnx3
    real (kind=8) :: xx,xim,xi,xip,xipp

    !     set "virtual" uniform increments

    dnx = 1.0/(nx-1)
    dmx = 1.0/(mx-1)
    odnx3 = 1.0/(6.*dnx*dnx*dnx)

    !     set i=ix(ii) in [2,nx-2] such that
    !     i-1,i,i+1,i+2 can be used to interpolate at ii

    DO ii=1,mx
      xx = (ii-1)*dmx
      ix(ii) = MIN0(MAX0(INT(xx/dnx)+1,2),nx-2)
      i = ix(ii)

    !     set scale terms for cubic

      xi = (i-1)*dnx
      xim = xi-dnx
      xip = xi+dnx
      xipp = xip+dnx
      dxm(ii) = -(xx-xi)*(xx-xip)*(xx-xipp)*odnx3
      dx(ii) = 3.*(xx-xim)*(xx-xip)*(xx-xipp)*odnx3
      dxp(ii) = -3.*(xx-xim)*(xx-xi)*(xx-xipp)*odnx3
      dxpp(ii) = (xx-xim)*(xx-xi)*(xx-xip)*odnx3
    END DO
    RETURN
    END SUBROUTINE cubnmxu
end module


*dk,hpsortip
      SUBROUTINE hpsortip(n,ia,ascend,iprm)
C
C
C#######################################################################
C
C     PURPOSE -
C
C     HPSORTIP ("HeaP SORT an Integer array, producing a
C     Permutaion") takes an integer N, an integer array IA,
C     an integer array IPRM of length N, and a real
C     number ASCEND, and
C     reorders IPRM so that IA(IPRM(1)),...,IA(IPRM(N))
C     is in ascending order if ASCEND is positive and
C     is in decreasing order if ASCEND is negative.
C
C     INPUT ARGUMENTS -
C
C        N - number of elements to be sorted.
C        IA - integer array of values which determine
C             how IPRM will be reordered.
C        IPRM - integer array to be reordered.  Strictly
c                        speaking, IPRM need not be a permutation of
c                        the integers {1,..,N}, but may be simply
c                        a mapping from {1,..,N} onto a set of N
c                        distinct positive integers.
C        ASCEND - real which controls whether we sort in ascending
C                 or descending order.
C
C     OUTPUT ARGUMENTS -
C
C        IPRM - reordered integer array.
C
C     CHANGE HISTORY -
C
C        $Log: hpsortip.f,v $
C        Revision 2.00  2007/11/03 00:49:11  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.0   22 Aug 2000 10:21:52   dcg
CPVCS    Initial revision.
CPVCS
CPVCS       Rev 1.0   Tue Aug 24 21:57:50 1999   kuprat
CPVCS    Initial revision.
C
C#######################################################################
C

      implicit none

      INTEGER n,ia(*)
      REAL*8 ascend
      INTEGER i,ir,j,l,iprm(n),irra
      if (n.lt.2) return
      l=n/2+1
      ir=n
10    continue
        if(l.gt.1)then
          l=l-1
          irra=iprm(l)
        else
          irra=iprm(ir)
          iprm(ir)=iprm(1)
          ir=ir-1
          if(ir.eq.1)then
            iprm(1)=irra
            return
          endif
        endif
        i=l
        j=l+l
20      if(j.le.ir)then
          if(j.lt.ir)then
            if(ascend*ia(iprm(j)).lt.ascend*ia(iprm(j+1)))j=j+1
          endif
          if(ascend*ia(irra).lt.ascend*ia(iprm(j)))then
            iprm(i)=iprm(j)
            i=j
            j=j+j
          else
            j=ir+1
          endif
        goto 20
        endif
        iprm(i)=irra
      goto 10
      END


!!!!!!!!!!!!!!!!!!!!!!
!! 1D boundary fixed!!
!! fixed value bc left
subroutine bc_val_1d_l(nxyz, ng, p, val)
implicit none
    integer :: ng
    integer :: i, j, k, nx, ny, nz
    integer, dimension(3) :: nxyz
    real, dimension(1-ng:nxyz(1)+ng) :: p
    real val

    p( 1-ng:0 ) = val
end subroutine bc_val_1d_l
!! right
subroutine bc_val_1d_r(nxyz, ng, p, val)
implicit none
    integer :: ng
    integer :: i, j, k, nx, ny, nz
    integer, dimension(3) :: nxyz
    real, dimension(1-ng:nxyz(1)+ng) :: p
    real val

    nx = nxyz(1)
    p(nx+1:nx+ng) = val
end subroutine bc_val_1d_r

!! homogenerous Neumann bc reft: outer border is equal with the most nearest(neighbour) cell of inner grid
subroutine bc_der_1d_l(nxyz, ng, p)
implicit none
    integer :: ng
    integer :: i, j, k, nx, ny, nz
    integer, dimension(3) :: nxyz
    real, dimension(1-ng:nxyz(1)+ng) :: p

    p(1-ng:0) = p(1:1)
end subroutine bc_der_1d_l
!! Neumann bc right
subroutine bc_der_1d_r(nxyz, ng, p)
implicit none
    integer :: ng
    integer :: i, j, k, nx, ny, nz
    integer, dimension(3) :: nxyz
    real, dimension(1-ng:nxyz(1)+ng) :: p

    nx = nxyz(1)
    p(nx+1:nx+ng) = p(nx:nx)
end subroutine bc_der_1d_r

!!!!!!!!!!!!!!!!!!!!!!!!
!! 1D pack and unpack !!
!! 1D left guard
subroutine packgc_1d_l(nxyz, ng, p, gdata)
implicit none
    integer :: ng
    integer, dimension(3) :: nxyz
    real, dimension(1-ng:nxyz(1)+ng) :: p
    real, dimension(1 : ng) :: gdata

    gdata( 1:ng ) = p( 1:ng )
end subroutine packgc_1d_l

!! 1D right guard
subroutine packgc_1d_r(nxyz, ng, p, gdata)
implicit none
    integer :: ng
    integer :: nx
    integer, dimension(3) :: nxyz
    real, dimension(1-ng : nxyz(1)+ng) :: p
    real, dimension(1 : ng) :: gdata

    nx = nxyz(1)
    gdata(1 : ng ) = p( nx-ng+1 : nx )
end subroutine packgc_1d_r

!! 1D left guard unpack
subroutine unpackgc_1d_l(nxyz, ng, p, gdata)
implicit none
    integer :: ng
    integer, dimension(3) :: nxyz
    real, dimension(1-ng:nxyz(1)+ng) :: p
    real, dimension(1 : ng) :: gdata

    p( 1-ng:0 ) = gdata( 1:ng )
end subroutine unpackgc_1d_l

subroutine unpackgc_1d_r(nxyz, ng, p, gdata)
implicit none
    integer :: ng
    integer :: nx
    integer, dimension(3) :: nxyz
    real, dimension(1-ng : nxyz(1)+ng) :: p
    real, dimension(1:ng) :: gdata

    nx = nxyz(1)
    p( nx+1 : nx+ng ) = gdata(1 : ng )
end subroutine unpackgc_1d_r

!! pull out the inner grid data
subroutine pack_1d(nxyz, ng, p, gdata)
implicit none
    integer :: ng, nx
    integer, dimension(3) :: nxyz
    real, dimension(1-ng:nxyz(1)+ng) :: p
    real, dimension(1 : nxyz(1)) :: gdata
    nx = nxyz(1)
    gdata( 1:nx ) = p( 1:nx )
end subroutine pack_1d

subroutine update_soln_1d(nxyz, ng, soln, delta)
implicit none
    integer, dimension(3) :: nxyz
    integer ::  ng, i, ix
    real, dimension(1-ng:nxyz(1)+ng ) :: soln, delta

    ix = nxyz(1)
    do i=1, ix
        soln(i) = soln(i) + delta(i)
    end do
end subroutine update_soln_1d


program test
  integer :: a(4, 3), b(4, 3, 5)
  integer :: i, j

  b = 0
  do i = 1, 4
  do j = 1, 3
      a(i, j) = 3
  end do
  end do

  forall(i=1:4, j=1:3, a(i, j) < 6) b(i, j, a(i, j)) = -1

  print *, b

end program test


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
PROGRAM testInterpolators
#include "UnitTest.h"
USE UnitTest
USE IntrType
USE InterpolatorsModule

IMPLICIT NONE

REAL(SRK) :: label1(3),label2(3),label3(3),Interpolant
REAL(SRK) :: table_1D(3),table_2D(3,3),table_3D(3,3,3)
!
CREATE_TEST('Interpolators')
!
REGISTER_SUBTEST('1-D Interpolator',test1DInterp)
REGISTER_SUBTEST('2-D Interpolator',test2DInterp)
REGISTER_SUBTEST('3-D Interpolator',test3DInterp)

FINALIZE_TEST()
!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
SUBROUTINE test1DInterp()

  COMPONENT_TEST('1D Asc. In Range')
  label1(1)=1.0_SRK
  label1(2)=2.0_SRK
  label1(3)=3.0_SRK
  table_1D(1)=40.0_SRK
  table_1D(2)=50.0_SRK
  table_1D(3)=75.0_SRK
  Interpolant=Interp(label1,table_1D,1.6_SRK)
  ASSERT_SOFTEQ(Interpolant,46.0_SRK,1e-14_SRK,'Incorrect Interpolant')

  COMPONENT_TEST('1D Asc. Out Of Range')
  Interpolant=Interp(label1,table_1D,0.4_SRK)
  ASSERT_SOFTEQ(Interpolant,40.0_SRK,1e-14_SRK,'Incorrect Interpolant')
  Interpolant=Interp(label1,table_1D,3.6_SRK)
  ASSERT_SOFTEQ(Interpolant,75.0_SRK,1e-14_SRK,'Incorrect Interpolant')

  COMPONENT_TEST('Asc. Bullseye')
  Interpolant=Interp(label1,table_1D,2.0_SRK)
  ASSERT_SOFTEQ(Interpolant,50.0_SRK,1e-14_SRK,'Incorrect Interpolant')

  COMPONENT_TEST('1D Des. In Range')
  label1(1)=3.0_SRK
  label1(2)=2.0_SRK
  label1(3)=1.0_SRK
  table_1D(1)=75.0_SRK
  table_1D(2)=50.0_SRK
  table_1D(3)=40.0_SRK
  Interpolant=Interp(label1,table_1D,1.6_SRK)
  ASSERT_SOFTEQ(Interpolant,46.0_SRK,1e-14_SRK,'Incorrect Interpolant')

  COMPONENT_TEST('1D Des. Out Of Range')
  Interpolant=Interp(label1,table_1D,0.4_SRK)
  ASSERT_SOFTEQ(Interpolant,40.0_SRK,1e-14_SRK,'Incorrect Interpolant')
  Interpolant=Interp(label1,table_1D,3.6_SRK)
  ASSERT_SOFTEQ(Interpolant,75.0_SRK,1e-14_SRK,'Incorrect Interpolant')

  COMPONENT_TEST('Des. Bullseye')
  Interpolant=Interp(label1,table_1D,2.0_SRK)
  ASSERT_SOFTEQ(Interpolant,50.0_SRK,1e-14_SRK,'Incorrect Interpolant')

ENDSUBROUTINE test1DInterp

SUBROUTINE test2DInterp()

  COMPONENT_TEST('2D Asc. In Range')
  label1(1)=1.0_SRK
  label1(2)=2.0_SRK
  label1(3)=3.0_SRK
  label2(1)=1.0_SRK
  label2(2)=2.0_SRK
  label2(3)=3.0_SRK
  table_2D(1,1)=40.0_SRK
  table_2D(2,1)=50.0_SRK
  table_2D(3,1)=75.0_SRK
  table_2D(1,2)=60.0_SRK
  table_2D(2,2)=80.0_SRK
  table_2D(3,2)=90.0_SRK
  table_2D(1,3)=100.0_SRK
  table_2D(2,3)=110.0_SRK
  table_2D(3,3)=120.0_SRK
  Interpolant=Interp(label1,label2,table_2D,[1.6_SRK,2.4_SRK])
  ASSERT_SOFTEQ(Interpolant,85.6_SRK,1e-14_SRK,'Incorrect Interpolant')

  COMPONENT_TEST('2D Asc. Out Of Range')
  Interpolant=Interp(label1,label2,table_2D,[0.5_SRK,2.4_SRK])
  ASSERT_SOFTEQ(Interpolant,76.0_SRK,1e-14_SRK,'Incorrect Interpolant')
  Interpolant=Interp(label1,label2,table_2D,[3.5_SRK,2.4_SRK])
  ASSERT_SOFTEQ(Interpolant,102.0_SRK,1e-14_SRK,'Incorrect Interpolant')
  Interpolant=Interp(label1,label2,table_2D,[1.6_SRK,0.5_SRK])
  ASSERT_SOFTEQ(Interpolant,46.0_SRK,1e-14_SRK,'Incorrect Interpolant')
  Interpolant=Interp(label1,label2,table_2D,[1.6_SRK,3.5_SRK])
  ASSERT_SOFTEQ(Interpolant,106.0_SRK,1e-14_SRK,'Incorrect Interpolant')

  COMPONENT_TEST('2D Des. In Range')
  label1(1)=3.0_SRK
  label1(2)=2.0_SRK
  label1(3)=1.0_SRK
  label2(1)=3.0_SRK
  label2(2)=2.0_SRK
  label2(3)=1.0_SRK
  table_2D(1,1)=120.0_SRK
  table_2D(2,1)=110.0_SRK
  table_2D(3,1)=100.0_SRK
  table_2D(1,2)=90.0_SRK
  table_2D(2,2)=80.0_SRK
  table_2D(3,2)=60.0_SRK
  table_2D(1,3)=75.0_SRK
  table_2D(2,3)=50.0_SRK
  table_2D(3,3)=40.0_SRK
  Interpolant=Interp(label1,label2,table_2D,[1.6_SRK,2.4_SRK])
  ASSERT_SOFTEQ(Interpolant,85.6_SRK,1e-14_SRK,'Incorrect Interpolant')

  COMPONENT_TEST('2D Des. Out Of Range')
  Interpolant=Interp(label1,label2,table_2D,[0.5_SRK,2.4_SRK])
  ASSERT_SOFTEQ(Interpolant,76.0_SRK,1e-14_SRK,'Incorrect Interpolant')
  Interpolant=Interp(label1,label2,table_2D,[3.5_SRK,2.4_SRK])
  ASSERT_SOFTEQ(Interpolant,102.0_SRK,1e-14_SRK,'Incorrect Interpolant')
  Interpolant=Interp(label1,label2,table_2D,[1.6_SRK,0.5_SRK])
  ASSERT_SOFTEQ(Interpolant,46.0_SRK,1e-14_SRK,'Incorrect Interpolant')
  Interpolant=Interp(label1,label2,table_2D,[1.6_SRK,3.5_SRK])
  ASSERT_SOFTEQ(Interpolant,106.0_SRK,1e-14_SRK,'Incorrect Interpolant')

ENDSUBROUTINE test2DInterp

SUBROUTINE test3DInterp()

  COMPONENT_TEST('3D Asc. In Range')
  label1(1)=1.0_SRK
  label1(2)=2.0_SRK
  label1(3)=3.0_SRK
  label2(1)=1.0_SRK
  label2(2)=2.0_SRK
  label2(3)=3.0_SRK
  label3(1)=1.0_SRK
  label3(2)=2.0_SRK
  label3(3)=3.0_SRK
  table_3D(1,1,1)=40.0_SRK
  table_3D(2,1,1)=50.0_SRK
  table_3D(3,1,1)=75.0_SRK
  table_3D(1,2,1)=60.0_SRK
  table_3D(2,2,1)=80.0_SRK
  table_3D(3,2,1)=90.0_SRK
  table_3D(1,3,1)=100.0_SRK
  table_3D(2,3,1)=110.0_SRK
  table_3D(3,3,1)=120.0_SRK
  table_3D(1,1,2)=40.0_SRK
  table_3D(2,1,2)=50.0_SRK
  table_3D(3,1,2)=75.0_SRK
  table_3D(1,2,2)=60.0_SRK
  table_3D(2,2,2)=80.0_SRK
  table_3D(3,2,2)=90.0_SRK
  table_3D(1,3,2)=100.0_SRK
  table_3D(2,3,2)=110.0_SRK
  table_3D(3,3,2)=120.0_SRK
  table_3D(1,1,3)=40.0_SRK
  table_3D(2,1,3)=50.0_SRK
  table_3D(3,1,3)=75.0_SRK
  table_3D(1,2,3)=60.0_SRK
  table_3D(2,2,3)=80.0_SRK
  table_3D(3,2,3)=90.0_SRK
  table_3D(1,3,3)=100.0_SRK
  table_3D(2,3,3)=110.0_SRK
  table_3D(3,3,3)=120.0_SRK
  Interpolant=Interp(label1,label2,label3,table_3D,[1.6_SRK,2.4_SRK,1.0_SRK])
  ASSERT_SOFTEQ(Interpolant,85.6_SRK,1e-14_SRK,'Incorrect Interpolant')

  COMPONENT_TEST('3D Asc. Out Of Range')
  Interpolant=Interp(label1,label2,label3,table_3D,[0.5_SRK,2.4_SRK,1.0_SRK])
  ASSERT_SOFTEQ(Interpolant,76.0_SRK,1e-14_SRK,'Incorrect Interpolant')
  Interpolant=Interp(label1,label2,label3,table_3D,[3.5_SRK,2.4_SRK,1.0_SRK])
  ASSERT_SOFTEQ(Interpolant,102.0_SRK,1e-14_SRK,'Incorrect Interpolant')
  Interpolant=Interp(label1,label2,label3,table_3D,[1.6_SRK,0.5_SRK,1.0_SRK])
  ASSERT_SOFTEQ(Interpolant,46.0_SRK,1e-14_SRK,'Incorrect Interpolant')
  Interpolant=Interp(label1,label2,label3,table_3D,[1.6_SRK,3.5_SRK,1.0_SRK])
  ASSERT_SOFTEQ(Interpolant,106.0_SRK,1e-14_SRK,'Incorrect Interpolant')
  Interpolant=Interp(label1,label2,label3,table_3D,[1.6_SRK,2.4_SRK,0.5_SRK])
  ASSERT_SOFTEQ(Interpolant,85.6_SRK,1e-14_SRK,'Incorrect Interpolant')
  Interpolant=Interp(label1,label2,label3,table_3D,[1.6_SRK,2.4_SRK,3.5_SRK])
  ASSERT_SOFTEQ(Interpolant,85.6_SRK,1e-14_SRK,'Incorrect Interpolant')

  COMPONENT_TEST('3D Des. In Range')
  label1(1)=3.0_SRK
  label1(2)=2.0_SRK
  label1(3)=1.0_SRK
  label2(1)=3.0_SRK
  label2(2)=2.0_SRK
  label2(3)=1.0_SRK
  label3(1)=3.0_SRK
  label3(2)=2.0_SRK
  label3(3)=1.0_SRK
  table_3D(1,1,1)=120.0_SRK
  table_3D(2,1,1)=110.0_SRK
  table_3D(3,1,1)=100.0_SRK
  table_3D(1,2,1)=90.0_SRK
  table_3D(2,2,1)=80.0_SRK
  table_3D(3,2,1)=60.0_SRK
  table_3D(1,3,1)=75.0_SRK
  table_3D(2,3,1)=50.0_SRK
  table_3D(3,3,1)=40.0_SRK
  table_3D(1,1,2)=120.0_SRK
  table_3D(2,1,2)=110.0_SRK
  table_3D(3,1,2)=100.0_SRK
  table_3D(1,2,2)=90.0_SRK
  table_3D(2,2,2)=80.0_SRK
  table_3D(3,2,2)=60.0_SRK
  table_3D(1,3,2)=75.0_SRK
  table_3D(2,3,2)=50.0_SRK
  table_3D(3,3,2)=40.0_SRK
  table_3D(1,1,3)=120.0_SRK
  table_3D(2,1,3)=110.0_SRK
  table_3D(3,1,3)=100.0_SRK
  table_3D(1,2,3)=90.0_SRK
  table_3D(2,2,3)=80.0_SRK
  table_3D(3,2,3)=60.0_SRK
  table_3D(1,3,3)=75.0_SRK
  table_3D(2,3,3)=50.0_SRK
  table_3D(3,3,3)=40.0_SRK
  Interpolant=Interp(label1,label2,label3,table_3D,[1.6_SRK,2.4_SRK,1.0_SRK])
  ASSERT_SOFTEQ(Interpolant,85.6_SRK,1e-14_SRK,'Incorrect Interpolant')

  COMPONENT_TEST('3D Des. Out Of Range')
  Interpolant=Interp(label1,label2,label3,table_3D,[0.5_SRK,2.4_SRK,1.0_SRK])
  ASSERT_SOFTEQ(Interpolant,76.0_SRK,1e-14_SRK,'Incorrect Interpolant')
  Interpolant=Interp(label1,label2,label3,table_3D,[3.5_SRK,2.4_SRK,1.0_SRK])
  ASSERT_SOFTEQ(Interpolant,102.0_SRK,1e-14_SRK,'Incorrect Interpolant')
  Interpolant=Interp(label1,label2,label3,table_3D,[1.6_SRK,0.5_SRK,1.0_SRK])
  ASSERT_SOFTEQ(Interpolant,46.0_SRK,1e-14_SRK,'Incorrect Interpolant')
  Interpolant=Interp(label1,label2,label3,table_3D,[1.6_SRK,3.5_SRK,1.0_SRK])
  ASSERT_SOFTEQ(Interpolant,106.0_SRK,1e-14_SRK,'Incorrect Interpolant')
  Interpolant=Interp(label1,label2,label3,table_3D,[1.6_SRK,2.4_SRK,0.5_SRK])
  ASSERT_SOFTEQ(Interpolant,85.6_SRK,1e-14_SRK,'Incorrect Interpolant')
  Interpolant=Interp(label1,label2,label3,table_3D,[1.6_SRK,2.4_SRK,3.5_SRK])
  ASSERT_SOFTEQ(Interpolant,85.6_SRK,1e-14_SRK,'Incorrect Interpolant')

ENDSUBROUTINE test3DInterp

ENDPROGRAM testInterpolators


PROGRAM Parallel_search
       ! This is a code to do a parallel search from the data file

       implicit none
       include 'mpif.h'
       integer, parameter :: n = 300
       integer, parameter :: endtag = 1
       integer, parameter :: resulttag = 2
       real, dimension(n) :: b
       integer :: rank, size, err, x, nloc
       integer :: status(MPI_STATUS_SIZE)
       integer :: iff, ill, i, j, gi
       real :: t1, t2, t_elapsed
       integer :: target
       target = 0

       call MPI_INIT(err)

       t1 = MPI_WTIME()

       call MPI_COMM_RANK(MPI_COMM_WORLD, rank, err)
       call MPI_COMM_SIZE(MPI_COMM_WORLD, size, err)

       if (size.le.1) then
               print *, "The program needs to have atleast 2 processors"
               goto 100
       end if

       !Determine the indices for domain decomposition
       call decompose(n, size, rank, iff, ill)
       if (rank.gt.0) then
               write(*,*) "rank=",rank,'out of',size, "indices", iff,ill
       end if

       ! Tasks for the master processor (processor zero)

       if (rank.eq.0) then

               ! Sending the target to the worker processors
               do i = 1, size-1
                        call MPI_SEND(target, 1, MPI_INTEGER, i, resulttag, MPI_COMM_WORLD, err)
               end do

               ! Read the data from the data file into the array b
               open(unit=10, file="data.txt")
                        do i = 1, n
                                read(10, *) b(i)
                        end do
               close(10)

               !Sending the subarrays to the workers
               do i = 1, size-1
                        call decompose(n, size, i, iff, ill)
                        nloc = ill - iff + 1
                        call MPI_SEND(b(iff), nloc, MPI_INTEGER, i, endtag, MPI_COMM_WORLD, err)
               end do

               !Opening the file to store the solution
               j = 0
               open(unit=20, file="result.txt")
                        do while (j.ne.size-1)
                                call MPI_RECV(x, 1, MPI_INTEGER, MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD, status, err)
                                if(status(MPI_TAG) == endtag) then
                                        j = j+1
                                else
                                        write(20,*) "Processor", status(MPI_SOURCE), x
                                end if
                        end do
               close(20)

       else

               ! The tasks of the workers

               call MPI_RECV(target, 1, MPI_INTEGER, 0, resulttag, MPI_COMM_WORLD, status, err)
               nloc = ill - iff + 1
               CALL MPI_RECV(b, nloc, MPI_INTEGER, 0, endtag, MPI_COMM_WORLD, status, err)

               do i = 1, nloc
                        if (b(i) == target) then
                                gi = i + iff - 1
                                call MPI_SEND(gi, 1, MPI_INTEGER, 0, resulttag, MPI_COMM_WORLD, err)
                        end if
               end do

               call MPI_SEND(target, 1, MPI_INTEGER, 0, endtag, MPI_COMM_WORLD, err)

       end if
       t2 = MPI_WTIME()
       t_elapsed = t1 - t2

       print *, "The total time elapsed is :", t_elapsed

100    call MPI_FINALIZE(err)

END PROGRAM

!---------------------------------------------------------------------------
subroutine decompose(n, size, rank, iff, ill)
        implicit none
        integer :: n, size, rank, iff, ill, neven
        neven = int(n/(size-1))
        iff = neven*(rank-1) + 1
        ill = neven*rank
        if (rank == size-1) then
                ill = ill + mod(n, size-1)
        end if
end subroutine


   program cube
!=======================================================================
!
!  Program to write 3D cube of wedge meshes
!
!  2020/07/15 - original program
!
!  Usage:  cube {num}
!    num - number of nodes along one edge
!
!=======================================================================
      use mod_vtklib3
      implicit none

      integer :: i
      integer :: ia
      integer :: iorder=6    ! wedges
      integer :: jjmax
      integer :: nnode=0     ! number of nodes
      integer :: nelem=0     ! number of elements
      integer :: nbnd        ! number of boundary nodes

      real(8) :: width=10.0d0   ! length of one side
      real(8) :: dz
      real(8) :: vsum
      real(8) :: xmax, xmin, ymax, ymin, zmax, zmin

      real(8), allocatable :: elarea(:)  ! (nelem)   element areas
      real(8), allocatable :: xi(:,:)    ! (3,nnode)
      integer, allocatable :: gg(:,:)    ! (iorder,nelem)
      integer, allocatable :: ibc(:)     ! (nnode)    boundary condition flag
      integer, allocatable :: imat(:)    ! (nelem)    material number
      integer, allocatable :: ihex(:)    ! (nelem)    hex (square) number

      character(len=100) :: fname='cube.vtk'
      character(len=10)  :: line

!--- read command line for size

      jjmax=10      ! number of points on edge, default

      ia=iargc()
      if (ia.gt.0) then
        call getarg(1,line)
        read (line,*) jjmax
      endif

!--- build square mesh

      nnode=(jjmax+1)**3
      nelem=2*jjmax*jjmax*jjmax

      write (*,*) 'nnode = ', nnode
      write (*,*) 'nelem = ', nelem

      allocate (xi(3,nnode))       ! x,y,z locations of each node
      allocate (gg(iorder,nelem))  ! map nodes to element
      allocate (ibc(nnode))        ! boundary conditions
      allocate (imat(nelem))       ! materials for each element
      allocate (ihex(nelem))       ! "hex number" for each element

      imat(:)=1
      ibc(:)=0

      call build_cube(jjmax, nelem, nnode, iorder, width, xi, gg, ibc, ihex)

!--- calculate element volumes (sanity checks)

      write (*,*)
      write (*,*) 'calculating element volumes'

      allocate (elarea(nelem))

      vsum=0.0d0
      do i=1, nelem
!d      write (*,'(4i4)') i, gg(:,i)
        elarea(i)=vtk_areatri(xi(1,gg(1,i)),xi(2,gg(1,i)), &
                              xi(1,gg(2,i)),xi(2,gg(2,i)), &
                              xi(1,gg(3,i)),xi(2,gg(3,i)))
        dz=xi(3,gg(4,i))-xi(3,gg(1,i))   ! assumes right wedge
        vsum=vsum+elarea(i)*dz
      enddo

      i=1
        xmax=xi(1,i)
        xmin=xi(1,i)
        ymax=xi(2,i)
        ymin=xi(2,i)
        zmax=xi(3,i)
        zmin=xi(3,i)
      do i=2, nnode
        xmax=max(xmax,xi(1,i))
        xmin=min(xmin,xi(1,i))
        ymax=max(ymax,xi(2,i))
        ymin=min(ymin,xi(2,i))
        zmax=max(zmax,xi(3,i))
        zmin=min(zmin,xi(3,i))
      enddo

      nbnd=0  ! number of boundary nodes
      do i=1, nnode
        if (ibc(i).ne.0) nbnd=nbnd+1
      enddo

      write (*,*)
      write (*,*) 'x min max ', xmin, xmax
      write (*,*) 'y min max ', ymin, ymax
      write (*,*) 'z min max ', zmin, zmax
      write (*,*) 'total volume = ', vsum
      write (*,*) 'number of boundary nodes = ', nbnd
      write (*,*)

!--- write mesh to VTK file

      write (*,'(/,2a)') ' creating vtk file: ', trim(fname)

      open (22,file=fname)
      call vtk_tri1(22, nnode, nelem, iorder, xi, gg)

      call vtk_tri2(22, nnode, ibc,  'bc',       'n')  ! nodal data
      call vtk_tri2(22, nelem, imat, 'material', 'e')  ! element data
      call vtk_tri2(22, nelem, ihex, 'hexnum',   ' ')  ! hex number
      close (22)

!--- finish

      write (*,*) 'deallocate'
      deallocate (xi,gg)
      deallocate (ibc)
      deallocate (imat)

      end

!=======================================================================
      subroutine build_cube(jjmax, nelem, nnode, iorder, width, xi, gg, ibc, ihex)
      implicit none
      integer, intent(in)  :: jjmax    ! number of points per side
      integer, intent(in)  :: nelem    ! number of elements
      integer, intent(in)  :: nnode    ! number of nodes
      integer, intent(in)  :: iorder   ! element order (6 for wedges)
      real(8), intent(in)  :: width    ! width of one side of cube
      real(8), intent(out) :: xi(3,nnode)   ! xyz points
      integer, intent(out) :: gg(iorder,nelem)   ! element map
      integer, intent(out) :: ibc(nnode)    ! boundary conditions
      integer, intent(out) :: ihex(nelem)   ! hex number

      integer :: i, j, k
      integer :: ne      ! element counter
      integer :: nn      ! node counter
      integer :: nesave  ! number of elements in one plane
      integer :: nnsave  ! number of nodes in one plane
      real(8) :: delx
      real(8) :: x, y, z

      write (*,*)
      write (*,*) 'building cube mesh of wedges'
      write (*,*) 'number of points along edge ', jjmax

      if (iorder.ne.6) stop 'error: iorder must be 6 for wedge elements'

      ibc(:)=0

      delx=width/dble(jjmax)  ! mesh width

!--- build first layer (square)

      nn=0
      ne=0

      z=0.0d0
      y=0.0d0
      do j=0, jjmax
        x=0.0d0
        do i=0,jjmax

           nn=nn+1
           xi(1,nn)=x
           xi(2,nn)=y
           xi(3,nn)=z
           x=x+delx

!bc        if (i.eq.0) ibc(nn)=3
!bc        if (j.eq.0) ibc(nn)=3
!bc        if (i.eq.jjmax) ibc(nn)=3
!bc        if (j.eq.jjmax) ibc(nn)=3

           if (i.ne.0 .and. y.ne.0) then    ! first nn is 11
             ne=ne+1
             gg(1,ne)=nn-jjmax-2       ! bottom layer
             gg(2,ne)=nn-jjmax-1
             gg(3,ne)=nn-1

             ihex(ne)=(i-1)*jjmax+j

             ne=ne+1
             gg(1,ne)=nn-1
             gg(2,ne)=nn-jjmax-1
             gg(3,ne)=nn

             ihex(ne)=ihex(ne-1)
           endif
        enddo
        y=y+delx
      enddo

      nesave=ne
      nnsave=nn

      do i=1, nesave      ! fill top nodes of bottom plane elements
        gg(4,i)=gg(1,i)+nnsave
        gg(5,i)=gg(2,i)+nnsave
        gg(6,i)=gg(3,i)+nnsave
      enddo

!--- extrude to 3D

      do k=1, jjmax
        z=z+delx
        do i=1, nnsave
          nn=nn+1
          xi(1,nn)=xi(1,nn-nnsave)
          xi(2,nn)=xi(2,nn-nnsave)
          xi(3,nn)=z
          ibc(nn)=ibc(nn-nnsave)
        enddo
      enddo
      if (nn.ne.nnode) stop 'nnode error in build_cube'

      do k=2, jjmax
        do i=1, nesave
          ne=ne+1
          gg(1,ne)=gg(1,ne-nesave)+nnsave
          gg(2,ne)=gg(2,ne-nesave)+nnsave
          gg(3,ne)=gg(3,ne-nesave)+nnsave
          gg(4,ne)=gg(4,ne-nesave)+nnsave
          gg(5,ne)=gg(5,ne-nesave)+nnsave
          gg(6,ne)=gg(6,ne-nesave)+nnsave
          ihex(ne)=ihex(ne-nesave)
        enddo
      enddo
      if (ne.ne.nelem) stop 'nelem error in build_cube'

      do i=1, ne
        if (gg(1,ne).le.0) stop 'negative gg'
        if (gg(2,ne).le.0) stop 'negative gg'
        if (gg(3,ne).le.0) stop 'negative gg'
        if (gg(4,ne).le.0) stop 'negative gg'
        if (gg(5,ne).le.0) stop 'negative gg'
        if (gg(6,ne).le.0) stop 'negative gg'
      enddo

!--- fix top and bottom bc

!  **** todo: make bc at top and bottom 3

!bc   do i=1, nnsave
!bc     ibc(nn)=3     ! bottom plane
!bc   enddo
!bc   do i=nnode-nnsave+1, nnode
!bc     ibc(nn)=3     ! top plane
!bc   enddo

      return
      end subroutine build_cube
!=======================================================================


subroutine setaux(mbc,mx,xlower,dx,maux,aux)

    ! Called at start of computation before calling qinit, and
    ! when AMR is used, also called every time a new grid patch is created.
    ! Use to set auxiliary arrays aux(1:maux, 1-mbc:mx+mbc, 1-mbc:my+mbc).
    ! Note that ghost cell values may need to be set if the aux arrays
    ! are used by the Riemann solver(s).
    !
    ! This version sets aux(1,:) to b(x) for shallow flow
    ! and aux(2,:) to the ratio of cell width to dxc (capacity function).

    !use geoclaw_module, only: dry_tolerance !uncomment if needed
    !use geoclaw_module, only: grav  !uncomment if needed
    use grid_module, only: xgrid,zgrid,mx_grid

    implicit none
    integer, intent(in) :: mbc,mx,maux
    real(kind=8), intent(in) :: xlower,dx
    real(kind=8), intent(out) ::  aux(maux,1-mbc:mx+mbc)

    !locals
    integer :: i,i0,i1,j
    real(kind=8) :: xcell,zcell,a

    if (mx .ne. mx_grid) then
        write(6,*) 'mx_grid from grid.data must agree with mx'
        stop
        endif

    do i=1,mx
        aux(1,i) = 0.5d0*(zgrid(i) + zgrid(i+1))
        aux(2,i) = (xgrid(i+1) - xgrid(i))/dx
        if (aux(2,i) <= 0.d0) then
            write(6,*) '+++ i,xgrid(i),xgrid(i+1): ',i,xgrid(i),xgrid(i+1)
            endif
    enddo

    aux(:,0) = aux(:,1)
    aux(:,-1) = aux(:,1)
    aux(:,mx+1) = aux(:,mx)
    aux(:,mx+2) = aux(:,mx)

end subroutine setaux


*     TD05AD EXAMPLE PROGRAM TEXT.
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NP1MAX, MP1MAX
      PARAMETER        ( NP1MAX = 20, MP1MAX = 20 )
*     .. Local Scalars ..
      DOUBLE PRECISION VALI, VALR, W
      INTEGER          I, INFO, MP1, NP1
      CHARACTER*1      UNITF, OUTPUT
*     .. Local Arrays ..
      DOUBLE PRECISION A(NP1MAX), B(MP1MAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         TD05AD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) NP1, MP1, W, UNITF, OUTPUT
      IF ( NP1.LE.0 .OR. NP1.GT.NP1MAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) NP1
      ELSE
         READ ( NIN, FMT = * ) ( A(I), I = 1,NP1 )
         IF ( MP1.LE.0 .OR. MP1.GT.MP1MAX ) THEN
            WRITE ( NOUT, FMT = 99994 ) MP1
         ELSE
            READ ( NIN, FMT = * ) ( B(I), I = 1,MP1 )
*           Find the real and imaginary parts of G(jW), where
*           W = 1.0 radian.
            CALL TD05AD( UNITF, OUTPUT, NP1, MP1, W, A, B, VALR, VALI,
     $                   INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               IF ( LSAME( OUTPUT, 'C' ) ) THEN
                  WRITE ( NOUT, FMT = 99997 ) VALR, VALI
               ELSE
                  WRITE ( NOUT, FMT = 99996 ) VALR, VALI
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TD05AD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TD05AD = ',I2)
99997 FORMAT (' Complex value of G(jW) = ',F8.4,1X,F8.4,'*j')
99996 FORMAT (' Magnitude of G(jW) = ',F8.4,' dBs, Phase of G(jW) = ',
     $       F8.4,' degrees ')
99995 FORMAT (/' NP1 is out of range.',/' NP1 = ',I5)
99994 FORMAT (/' MP1 is out of range.',/' MP1 = ',I5)
      END


      DOUBLE PRECISION   FUNCTION DNRM2( N, X, INCX )
*
*  -- Automatically Tuned Linear Algebra Software (ATLAS)
*     (C) Copyright 2000 All Rights Reserved
*
*  -- ATLAS routine -- F77 Interface -- Version 3.9.24 -- December 25, 2000
*
*  Author         : Antoine P. Petitet
*  Originally developed at the University of Tennessee,
*  Innovative Computing Laboratory,  Knoxville TN, 37996-1301, USA.
*
*  ---------------------------------------------------------------------
*
*  -- Copyright notice and Licensing terms:
*
*  Redistribution  and  use in  source and binary forms, with or without
*  modification, are  permitted provided  that the following  conditions
*  are met:
*
*  1. Redistributions  of  source  code  must retain the above copyright
*     notice, this list of conditions and the following disclaimer.
*  2. Redistributions in binary form must reproduce  the above copyright
*     notice,  this list of conditions, and the  following disclaimer in
*     the documentation and/or other materials provided with the distri-
*     bution.
*  3. The name of the University,  the ATLAS group,  or the names of its
*     contributors  may not be used to endorse or promote products deri-
*     ved from this software without specific written permission.
*
*  -- Disclaimer:
*
*  THIS  SOFTWARE  IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
*  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,  INCLUDING,  BUT NOT
*  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
*  A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY
*  OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,  INDIRECT, INCIDENTAL, SPE-
*  CIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
*  TO,  PROCUREMENT  OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
*  OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEO-
*  RY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT  (IN-
*  CLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
*  THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
*  ---------------------------------------------------------------------
*
*     .. Scalar Arguments ..
      INTEGER            INCX, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   X( * )
*     ..
*
*  Purpose
*  =======
*
*  DNRM2 returns the 2-norm of an n-vector x.
*
*  Arguments
*  =========
*
*  N       (input)                       INTEGER
*          On entry, N specifies the length of the vector x. N  must  be
*          at least zero. Unchanged on exit.
*
*  X       (input)                       DOUBLE PRECISION array
*          On entry,  X  is an incremented array of dimension  at  least
*          ( 1 + ( n - 1 ) * abs( INCX ) )  that  contains the vector x.
*          Unchanged on exit.
*
*  INCX    (input)                       INTEGER
*          On entry, INCX specifies the increment for the elements of X.
*          INCX must not be zero. Unchanged on exit.
*
*  Further Details
*  ===============
*
*  For further information on the Level 1 BLAS specification, see:
*
*  ``A Proposal for Standard Linear Algebra Subprograms''  by R. Hanson,
*  F. Krogh and C. Lawson, ACM SIGNUM Newsl., 8(16), 1973,
*
*  ``Basic Linear Algebra Subprograms for Fortran Usage''  by C. Lawson,
*  R. Hanson, D. Kincaid and F. Krogh,  ACM Transactions on Mathematical
*  Software, 5(3) pp 308-323, 1979.
*
*  For further information on the Level 2 BLAS specification, see:
*
*  ``An  Extended Set of  FORTRAN  Basic Linear Algebra Subprograms'' by
*  J. Dongarra,  J. Du Croz,  S. Hammarling and R. Hanson,  ACM Transac-
*  tions on Mathematical Software, 14(1) pp 1-17, 1988.
*
*  ``Algorithm 656: An extended Set of Basic Linear Algebra Subprograms:
*  Model Implementation and Test Programs''  by J. Dongarra, J. Du Croz,
*  S. Hammarling and R. Hanson,  ACM  Transactions on Mathematical Soft-
*  ware, 14(1) pp 18-32, 1988.
*
*  For further information on the Level 3 BLAS specification, see:
*
*  ``A Set of Level 3 Basic Linear Algebra Subprograms'' by J. Dongarra,
*  J. Du Croz, I. Duff and S. Hammarling, ACM Transactions on Mathemati-
*  cal Software, 16(1), pp 1-17, 1990.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   NORM2
*     ..
*     .. External Subroutines ..
      EXTERNAL           ATL_F77WRAP_DNRM2
*     ..
*     .. Executable Statements ..
*
      IF( N.GT.0 ) THEN
         CALL ATL_F77WRAP_DNRM2( N, X, INCX, NORM2 )
         DNRM2 = NORM2
      ELSE
         DNRM2 = ZERO
      END IF
*
      RETURN
*
*     End of DNRM2
*
      END


!!!!!
! This subroutine implements the simple Hapke soil reflectance model,
! which averages reflectance spectra of fully wet soil and fully dry
! soil weighted by a soil moisture coefficient between 0 and 1.
!!!!!

module mod_hapke_soil
contains
function hapke_soil(soil_moisture) result(rho_soil)
    ! Simple soil reflectance model as a function of soil moisture
    use mod_dataspec_wavelength
    use mod_dataspec_soil
    implicit none

    real*8, intent(in) :: soil_moisture
    real*8, dimension(nw) :: rho_soil

    rho_soil = soil_moisture * Rsoil1 + (1 - soil_moisture) * Rsoil2
end function hapke_soil
end module mod_hapke_soil


      SUBROUTINE SQRT02( M, N, K, A, AF, Q, R, LDA, TAU, 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            K, LDA, LWORK, M, N
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), AF( LDA, * ), Q( LDA, * ),
     $                   R( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
     $                   WORK( LWORK )
*     ..
*
*  Purpose
*  =======
*
*  SQRT02 tests SORGQR, which generates an m-by-n matrix Q with
*  orthonornmal columns that is defined as the product of k elementary
*  reflectors.
*
*  Given the QR factorization of an m-by-n matrix A, SQRT02 generates
*  the orthogonal matrix Q defined by the factorization of the first k
*  columns of A; it compares R(1:n,1:k) with Q(1:m,1:n)'*A(1:m,1:k),
*  and checks that the columns of Q are orthonormal.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix Q to be generated.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix Q to be generated.
*          M >= N >= 0.
*
*  K       (input) INTEGER
*          The number of elementary reflectors whose product defines the
*          matrix Q. N >= K >= 0.
*
*  A       (input) REAL array, dimension (LDA,N)
*          The m-by-n matrix A which was factorized by SQRT01.
*
*  AF      (input) REAL array, dimension (LDA,N)
*          Details of the QR factorization of A, as returned by SGEQRF.
*          See SGEQRF for further details.
*
*  Q       (workspace) REAL array, dimension (LDA,N)
*
*  R       (workspace) REAL array, dimension (LDA,N)
*
*  LDA     (input) INTEGER
*          The leading dimension of the arrays A, AF, Q and R. LDA >= M.
*
*  TAU     (input) REAL array, dimension (N)
*          The scalar factors of the elementary reflectors corresponding
*          to the QR factorization in AF.
*
*  WORK    (workspace) REAL array, dimension (LWORK)
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK.
*
*  RWORK   (workspace) REAL array, dimension (M)
*
*  RESULT  (output) REAL array, dimension (2)
*          The test ratios:
*          RESULT(1) = norm( R - Q'*A ) / ( M * norm(A) * EPS )
*          RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
      REAL               ROGUE
      PARAMETER          ( ROGUE = -1.0E+10 )
*     ..
*     .. Local Scalars ..
      INTEGER            INFO
      REAL               ANORM, EPS, RESID
*     ..
*     .. External Functions ..
      REAL               SLAMCH, SLANGE, SLANSY
      EXTERNAL           SLAMCH, SLANGE, SLANSY
*     ..
*     .. External Subroutines ..
      EXTERNAL           SGEMM, SLACPY, SLASET, SORGQR, SSYRK
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, REAL
*     ..
*     .. Scalars in Common ..
      CHARACTER*6        SRNAMT
*     ..
*     .. Common blocks ..
      COMMON             / SRNAMC / SRNAMT
*     ..
*     .. Executable Statements ..
*
      EPS = SLAMCH( 'Epsilon' )
*
*     Copy the first k columns of the factorization to the array Q
*
      CALL SLASET( 'Full', M, N, ROGUE, ROGUE, Q, LDA )
      CALL SLACPY( 'Lower', M-1, K, AF( 2, 1 ), LDA, Q( 2, 1 ), LDA )
*
*     Generate the first n columns of the matrix Q
*
      SRNAMT = 'SORGQR'
      CALL SORGQR( M, N, K, Q, LDA, TAU, WORK, LWORK, INFO )
*
*     Copy R(1:n,1:k)
*
      CALL SLASET( 'Full', N, K, ZERO, ZERO, R, LDA )
      CALL SLACPY( 'Upper', N, K, AF, LDA, R, LDA )
*
*     Compute R(1:n,1:k) - Q(1:m,1:n)' * A(1:m,1:k)
*
      CALL SGEMM( 'Transpose', 'No transpose', N, K, M, -ONE, Q, LDA, A,
     $            LDA, ONE, R, LDA )
*
*     Compute norm( R - Q'*A ) / ( M * norm(A) * EPS ) .
*
      ANORM = SLANGE( '1', M, K, A, LDA, RWORK )
      RESID = SLANGE( '1', N, K, R, LDA, RWORK )
      IF( ANORM.GT.ZERO ) THEN
         RESULT( 1 ) = ( ( RESID / REAL( MAX( 1, M ) ) ) / ANORM ) / EPS
      ELSE
         RESULT( 1 ) = ZERO
      END IF
*
*     Compute I - Q'*Q
*
      CALL SLASET( 'Full', N, N, ZERO, ONE, R, LDA )
      CALL SSYRK( 'Upper', 'Transpose', N, M, -ONE, Q, LDA, ONE, R,
     $            LDA )
*
*     Compute norm( I - Q'*Q ) / ( M * EPS ) .
*
      RESID = SLANSY( '1', 'Upper', N, R, LDA, RWORK )
*
      RESULT( 2 ) = ( RESID / REAL( MAX( 1, M ) ) ) / EPS
*
      RETURN
*
*     End of SQRT02
*
      END