c ### module: fortlib
c --- method: distance
      subroutine distance(cc,iopt,rij,natm,ndim)
c     return distance rij in linear array.
c     usage: rij=fuflib.distance(cc,0)
c     iopt: =0,retrun distance in rij, =1 square of distance
      implicit none
      integer ndim,natm
      real(8) cc(natm,ndim)
      integer iopt
      real(8) rij(natm*(natm-1)/2)
c
      integer i,j,k
      real(8) r2,dx,dy,dz
c
      k=0
      do i=1,natm-1
          do j=i+1,natm
              k=k+1
              dx=cc(i,1)-cc(j,1)
              dy=cc(i,2)-cc(j,2)
              dz=cc(i,3)-cc(j,3)
              r2=dx*dx+dy*dy+dz*dz
              rij(k)=r2
          enddo
      enddo
c     iopt.eq.0, return sqrt(r2)
      if (iopt.eq.0) then
           do i=1,k
               rij(i)=sqrt(rij(i))
           enddo
       endif
c
       return
       end

c --- method: find_contact_atoms
      subroutine find_contact_atoms(cc1,cc2,rmin,rmax,natm,iatm,ndim,
     .                              natm1,natm2)
c     calculate distance between atom groups 1 and 2 whose coordinates
c     are in cc1 and cc2, respectively, and
c     return sequence number of atoms in 2 located within threshold
c     distance from atoms in 1.
      implicit none
      integer ndim,natm1,natm2
      real(8) rmin,rmax
      real(8) cc1(natm1,ndim)
      real(8) cc2(natm2,ndim)
      integer natm
      integer iatm(natm2)
c
      integer itmp(natm2),jtmp(natm2)
      integer i,j
      real(8) rmin2,rmax2,r2,dx,dy,dz

c     write(*,*) ' entered in find_contact_atoms'

      rmin2=rmin*rmin
      rmax2=rmax*rmax
      do j=1,natm2
          jtmp(j)=1
          itmp(j)=0
      enddo
      do j=1,natm2
          do i=1,natm1
              dx=cc1(i,1)-cc2(j,1)
              dy=cc1(i,2)-cc2(j,2)
              dz=cc1(i,3)-cc2(j,3)
              r2=dx*dx+dy*dy+dz*dz
              if (r2.lt.rmax2) then
                  itmp(j)=1
              endif
              if (r2.lt.rmin2) then
                  jtmp(j)=0
              endif
          enddo
      enddo

      do i=1,natm2
          iatm(i)=-1
      enddo
c
      natm=0
      do i=1,natm2
          if (itmp(i).eq.1 .and. jtmp(i).eq.1) then
               natm=natm+1
               iatm(natm)=i-1
          endif
       enddo
c
       return
       end

c --- method: find_contact_atoms0
      subroutine find_contact_atoms0(cc1,cc2,rmin,rmax,iopt,npair,iatm,
     .                               jatm,rij,ndim,natm1,natm2)
c     calculate distance between atom groups 1 and 2 whose coordinates
c     are in cc1 and cc2, respectively, and
c     return sequence number of atoms in 2 located within threshold
c     distance from atoms in 1.
      implicit none
      integer ndim,natm1,natm2
      real(8) rmin,rmax
      integer iopt
      real(8) cc1(natm1,ndim)
      real(8) cc2(natm2,ndim)
      integer npair
      integer iatm(natm1*natm2),jatm(natm1*natm2)
      real*8 rij(natm1*natm2)
c
      integer i,j
      real(8) rmin2,rmax2,r2,dx,dy,dz

c     write(*,*) ' entered in find_contact_atoms'

      rmin2=rmin*rmin
      rmax2=rmax*rmax
      npair=0
      do i=1,natm1
          do j=1,natm2
              dx=cc1(i,1)-cc2(j,1)
              dy=cc1(i,2)-cc2(j,2)
              dz=cc1(i,3)-cc2(j,3)
              r2=dx*dx+dy*dy+dz*dz
              if (r2.lt.rmax2 .and. r2.ge.rmin2) then
                  npair=npair+1
                  iatm(npair)=i-1
                  jatm(npair)=j-1
                  rij(npair)=r2
              endif
          enddo
      enddo
c
      if (iopt.eq.0) then
          do j=1,npair
              rij(i)=sqrt(rij(i))
          enddo
       endif
c
       return
       end

c --- method: find_contact_atoms1
      subroutine find_contact_atoms1(cc,rad,margin,n,iatm,jatm,
     .                               ndim,natm)
c     return contact atom pairis in 'iatm' and 'jatm'. The radii
c     are given in 'rad' and 'margin' is for rad(i)+rad(j)
      implicit none
      integer ndim,natm
      real(8) cc(natm,ndim)
      real(8) rad(natm)
      real(8) margin
      integer n
      integer iatm(10*natm)
      integer jatm(10*natm)
      real(8) vij(ndim), ccj(ndim)
      integer i,j,k,maxpair
      real(8) t2,r2

      maxpair=10*natm
c     write(*,*) ' entered in find_contact_atoms1'

      do i=1,natm
          iatm(i)=-1
          jatm(i)=-1
      enddo
      k=0
      do j=1,natm
          ccj(1)=cc(j,1)
          ccj(2)=cc(j,2)
          ccj(3)=cc(j,3)
          do i=1,j-1
              vij(1)=cc(i,1)-ccj(1)
              vij(2)=cc(i,2)-ccj(2)
              vij(3)=cc(i,3)-ccj(3)
              r2=vij(1)*vij(1)+vij(2)*vij(2)+vij(3)*vij(3)
              t2=margin*(rad(i)+rad(j))**2
              if (r2 < t2) then
                  k=k+1
                  if ( k > maxpair) then
                       write(*,*) 'Program error(find_contact_atoms):
     . insufficient dimension'
                       exit
                  endif
                 iatm(k)=i-1
                 jatm(k)=j-1
              endif
          enddo
      enddo
      n=k
      return
      end

c --- method: find_contact_atoms2
      subroutine find_contact_atoms2(cc,rmin,rmax,iopt,npair,
     .                               iatm,jatm,rij,natm,ndim)
c     return short contact atoms within rmin < r < rmax.
c     usage: npair,iatm,jatm,rij=fuflib.find_contact_atoms2(cc,rmin,rmax,0)
c     the atomic pair in iatm and jatm and diatance in rij.
c     iopt: =0,retrun distance in rij, =1 square of distance
      implicit none
      integer ndim,natm
      real(8) cc(natm,ndim)
      real(8) rmin,rmax
      integer iopt
      integer npair
      integer iatm(10*natm),jatm(10*natm)
      real(8) rij(10*natm)
c
      integer i,j,maxpair
      real(8) rmin2,rmax2,r2,dx,dy,dz
c
c     write(*,*) ' entered in find_contact_atoms2'

      maxpair=10*natm

      rmin2=rmin*rmin
      rmax2=rmax*rmax
      npair=0
      do i=1,natm-1
          do j=i+1,natm
              dx=cc(i,1)-cc(j,1)
              dy=cc(i,2)-cc(j,2)
              dz=cc(i,3)-cc(j,3)
              r2=dx*dx+dy*dy+dz*dz
              if (r2.lt.rmax2 .and. r2.ge.rmin2) then
                  npair=npair+1
                  if (npair .gt. maxpair) then
                       write(*,*) 'napir exceeded maxpair!'
                       exit
                  endif
                  iatm(npair)=i-1
                  jatm(npair)=j-1
                  rij(npair)=r2
              endif
          enddo
      enddo
c     iopt.eq.0, return sqrt(r2)
      if (iopt.eq.0) then
           do i=1,npair
               rij(i)=sqrt(rij(i))
           enddo
       endif
c
       return
       end

c --- method: find_contact_atoms3
      subroutine find_contact_atoms3(x,y,z,cc,rmin,rmax,iopt,
     .                              npnt,iatm,rij,natm,ndim)
c     return atoms locating within threshold ditance from x,y,z point.
c     iopt: =0, return distance, =1, distance**2
      implicit none
      integer ndim,natm
      real(8) x,y,z
      real(8) cc(natm,ndim)
      real(8) rmin,rmax
      integer iopt
      integer npnt
      integer iatm(natm)
      real(8) rij(natm)

      integer i
      real(8) rmin2,rmax2,r2,dx,dy,dz

c     write(*,*) ' entered in find_contact_atoms3'

      rmin2=rmin*rmin
      rmax2=rmax*rmax
      npnt=0
      do i=1,natm
          dx=x-cc(i,1)
          dy=y-cc(i,2)
          dz=z-cc(i,3)
          r2=dx*dx+dy*dy+dz*dz
          if (r2.lt.rmax2 .and. r2.ge.rmin2) then
              npnt=npnt+1
              iatm(npnt)=i-1
              rij(npnt)=r2
          endif
      enddo
c     iopt.eq.0, return sqrt(r2)
      if (iopt.eq.0) then
           do i=1,npnt
               rij(i)=sqrt(rij(i))
           enddo
       endif
c
       return
       end

c---- method: chisq_cc
      subroutine chisq_cc(cc0,cc1,chisq,natm)
c     compute chi square between two coordinate sets, cc0 and cc1
      implicit none
      real(8)  cc0(natm,3),cc1(natm,3)
      integer  natm

      real(8) chisq
      integer i,j

      chisq=0.0
      do i=1,3
          do j=1,natm
              chisq=chisq+(cc0(j,i)-cc1(j,i))*(cc0(j,i)-cc1(j,i))
          enddo
      enddo
      return
      end

c --- method: dist_cc
      subroutine dist_cc(cc0,cc1,rmin,rmax,na,iatm,r,natm)
c     return atomic distance r between two coordinates, cc0 and cc1
c     distances within rmin and rmax are returned
      real(8) cc0(natm,3),cc1(natm,3)
      real(8) r(natm)
      real(8) rmin,rmax
      integer na,natm
      integer iatm(natm)

      integer i,j,k
      real(8) r2,rmin2,rmax2

      rmin2=rmin*rmin
      rmax2=rmax*rmax
      do i=1,natm
          iatm(i)=-1
          r(i)=-1.0
      enddo
      k=0
      do i=1,natm
          r2=0.0
          do j=1,3
              r2=r2+(cc0(i,j)-cc1(i,j))**2
          enddo
          if (r2 .gt. rmin2 .and. r2 .lt. rmax2) then
              k=k+1
              iatm(k)=i
              r(k)=sqrt(r2)
          endif
      enddo
      na=k

      return
      end

c --- method: get_atom_at_raspos
      subroutine get_atom_at_raspos(x,y,atmseq,rasterx,rastery,iatm,
     .                              nsiz)
c     find sequence number of atom at raster position (x,y)
      implicit none
      integer nsiz
      real(8) x,y
      integer atmseq(nsiz)
      real(8) rasterx(nsiz)
      real(8) rastery(nsiz)
      integer iatm
      integer i

c     write(*,*) ' entered in get_atom_at_raspos'

      iatm=-1
      do i=1,nsiz
          if (abs(x-rasterx(i)) < 5 .and. abs(y-rastery(i)) < 5) then
              iatm=atmseq(i)
              exit
          endif
      enddo
      return
      end

c --- potential function for flatten molecule
      subroutine flatten_func(cc,ibnd,jbnd,rbnd,ifix,ccfix,
     .                       fb,fnb1,fnb2,fz,fix,
     .                       e,natm,ndim,nbnd,nfix)
      implicit none
      real*8 cc(natm,ndim),rbnd(nbnd),ccfix(nfix,ndim)
      integer ibnd(nbnd),jbnd(nbnd),ifix(nfix)
      real*8 fb,fnb1,fnb2,fz,fix
      integer ndim,natm,nbnd,nfix
      real*8 e
c
      integer i,j,ii,jj
      real*8 dx,dy,dz,zi,dr,rij,rij0,rij2,rij4
c
c     write(*,*) ' entered in flatten_func'

      e=0.0
c     fix atom potential; harmomic constraint at a positon
      do i=1,nfix
          ii=ifix(i)
          if (ii .le. 0) exit
          dx=cc(ii,1)-ccfix(i,1)
          dy=cc(ii,2)-ccfix(i,2)
          dz=cc(ii,3)-ccfix(i,3)
          e=e+fix*(dx*dx+dy*dy+dz*dz)
      enddo
c     non-bond term ... fnb1/r**4 fnb2/r**2 and two-d projection
c     potential fz*z**2
      do i=1,natm
          zi=cc(i,3)
          e=e+fz*zi*zi
      enddo
      do i=1,natm-1
          do j=i+1,natm
              dx=cc(j,1)-cc(i,1)
              dy=cc(j,2)-cc(i,2)
              dz=cc(j,3)-cc(i,3)
              rij2=dx*dx+dy*dy+dz*dz
              rij4=rij2*rij2
              e=e+fnb1/rij4
              e=e+fnb2/rij2
          enddo
      enddo
c     bond term ... fb*(r-r0)**2
      do i=1,nbnd
          ii=ibnd(i)
          jj=jbnd(i)
          rij0=rbnd(i)
          dx=cc(ii,1)-cc(jj,1)
          dy=cc(ii,2)-cc(jj,2)
          dz=cc(ii,3)-cc(jj,3)
          rij2=dx*dx+dy*dy+dz*dz
          rij=sqrt(rij2)
          dr=rij-rij0
          e=e+fb*dr*dr
          rij4=rij2*rij2
c         remove contribution of bonds to non-bond term
          e=e-fnb1/rij4
          e=e-fnb2/rij2
      enddo

      return
      end

c --- gradient function for 2d-projection of molecule
      subroutine flatten_func_grad(cc,ibnd,jbnd,rbnd,ifix,ccfix,
     .                         fb,fnb1,fnb2,fz,fix,e,de,
     .                         natm,ndim,nbnd,nfix)
      implicit none
      real*8   cc(natm,ndim),rbnd(nbnd),ccfix(nfix,ndim)
      integer  ibnd(nbnd),jbnd(nbnd),ifix(nfix)
      real*8   fb,fnb1,fnb2,fz,fix
      integer  ndim,natm,nbnd,nfix
      real*8   e,de(natm,ndim)
c
      integer i,j,ii,jj
      real*8 dx,dy,dz,zi,dr,rij,rij0,rij2,rij4,gx,gy,gz,fc,fc2,fc4
c
c     write(*,*) ' entered in flattten_func_grad'

      e=0.0
      do i=1,natm
          de(i,1)=0.0
          de(i,2)=0.0
          de(i,3)=0.0
      enddo
c     fix atom potential
      fc=2.0*fix
      do i=1,nfix
          ii=ifix(i)
          if (ii .le. 0) exit
          dx=cc(ii,1)-ccfix(i,1)
          dy=cc(ii,2)-ccfix(i,2)
          dz=cc(ii,3)-ccfix(i,3)
          e=e+fix*(dx*dx+dy*dy+dz*dz)
          de(ii,1)=de(ii,1)+fc*dx
          de(ii,2)=de(ii,2)+fc*dy
          de(ii,3)=de(ii,3)+fc*dz
      enddo
c     non-bond term ... fnb1/r**4 fnb2/r**2 and two-d projection
c     potential fz*z**2
      do i=1,natm
          zi=cc(i,3)
          e=e+fz*zi*zi
          gz=2.0*fz*zi
          de(i,3)=de(i,3)+gz
      enddo
      do i=1,natm-1
          do j=i+1,natm
              dx=cc(i,1)-cc(j,1)
              dy=cc(i,2)-cc(j,2)
              dz=cc(i,3)-cc(j,3)
              rij2=dx*dx+dy*dy+dz*dz
              rij=sqrt(rij2)
              rij4=rij2*rij2
              e=e+fnb1/rij4
              e=e+fnb2/rij2
              fc4=-4.0*fnb1/(rij4*rij2)
              fc2=-2.0*fnb2/rij4
              fc=fc2+fc4
              gx=fc*dx
              gy=fc*dy
              gz=fc*dz
              de(i,1)=de(i,1)+gx
              de(i,2)=de(i,2)+gy
              de(i,3)=de(i,3)+gz
              de(j,1)=de(j,1)-gx
              de(j,2)=de(j,2)-gy
              de(j,3)=de(j,3)-gz
          enddo
      enddo
c     bond term ... fb*(r-r0)**2
      do i=1,nbnd
          ii=ibnd(i)
          jj=jbnd(i)
          rij0=rbnd(i)
          dx=cc(ii,1)-cc(jj,1)
          dy=cc(ii,2)-cc(jj,2)
          dz=cc(ii,3)-cc(jj,3)
          rij2=dx*dx+dy*dy+dz*dz
          rij=sqrt(rij2)
          dr=rij-rij0
          e=e+fb*dr*dr
          fc=2.0*fb*dr/rij
          gx=fc*dx
          gy=fc*dy
          gz=fc*dz
          de(ii,1)=de(ii,1)+gx
          de(ii,2)=de(ii,2)+gy
          de(ii,3)=de(ii,3)+gz
          de(jj,1)=de(jj,1)-gx
          de(jj,2)=de(jj,2)-gy
          de(jj,3)=de(jj,3)-gz
c         remove contribution of bonds to non-bond term
          rij4=rij2*rij2
          e=e-fnb1/rij4
          e=e-fnb2/rij2
          fc4=-4.0*fnb1/(rij4*rij2)
          fc2=-2.0*fnb2/rij4
          fc=fc2+fc4
          gx=fc*dx
          gy=fc*dy
          gz=fc*dz
          de(ii,1)=de(ii,1)-gx
          de(ii,2)=de(ii,2)-gy
          de(ii,3)=de(ii,3)-gz
          de(jj,1)=de(jj,1)+gx
          de(jj,2)=de(jj,2)+gy
          de(jj,3)=de(jj,3)+gz
      enddo

      return
      end
c --- function for Hb hydrogen position optimization
      subroutine hb_func(cc,q,ibnd,jbnd,rbnd,ifix,ccfix,
     .                        fb,fx,e,natm,ndim,nfix,nbnd)
      implicit none
      real*8   cc(natm,ndim),rbnd(nbnd),ccfix(nfix,ndim)
      real*8   q(natm)
      integer  ibnd(nbnd),jbnd(nbnd),ifix(nfix)
      real*8   fb,fx
      integer  ndim,natm,nbnd,nfix
      real*8   e
c
      integer i,j,ii,jj
      real*8 dx,dy,dz,zi,dr,rij,rij0,rij2,rij4,gx,gy,gz,fc,fc2,fc4,qu
c
      qu=505.4
c
      e=0.0
c     fix atom potential
      do i=1,nfix
          ii=ifix(i)+1
          if (ii .le. 0) exit
          dx=cc(ii,1)-ccfix(i,1)
          dy=cc(ii,2)-ccfix(i,2)
          dz=cc(ii,3)-ccfix(i,3)
          e=e+fx*(dx*dx+dy*dy+dz*dz)
      enddo
c     subtract charge interactions between fixed atoms
      do i=1,nfix-1
          ii=ifix(i)+1
          do j=i+1,nfix
              jj=ifix(j)+1
              dx=cc(ii,1)-cc(jj,1)
              dy=cc(ii,2)-cc(jj,2)
              dz=cc(ii,3)-cc(jj,3)
              rij2=dx*dx+dy*dy+dz*dz
              rij=sqrt(rij2)
              e=e-qu*q(ii)*q(jj)/rij
          enddo
      enddo
c     charge-charge interactions
      do i=1,natm-1
          do j=i+1,natm
              dx=cc(i,1)-cc(j,1)
              dy=cc(i,2)-cc(j,2)
              dz=cc(i,3)-cc(j,3)
              rij2=dx*dx+dy*dy+dz*dz
              rij=sqrt(rij2)
              fc=qu*q(i)*q(j)
              e=e+fc/rij
          enddo
      enddo
c     bond term ... fb*(r-r0)**2
      do i=1,nbnd
          ii=ibnd(i)+1
          jj=jbnd(i)+1
          rij0=rbnd(i)
          dx=cc(ii,1)-cc(jj,1)
          dy=cc(ii,2)-cc(jj,2)
          dz=cc(ii,3)-cc(jj,3)
          rij2=dx*dx+dy*dy+dz*dz
          rij=sqrt(rij2)
          dr=rij-rij0
          e=e+fb*dr*dr
c         subtract contribution of bonds to cgarhe-charge int
          fc=qu*q(ii)*q(jj)
          e=e-fc/rij
      enddo

      return
      end

c --- gradient function for Hb hydrogen position optimization
      subroutine hb_func_grad(cc,q,ibnd,jbnd,rbnd,ifix,ccfix,
     .                        fb,fx,e,de,natm,ndim,nfix,nbnd)
      implicit none
      real*8   cc(natm,ndim),rbnd(nbnd),ccfix(nfix,ndim)
      real*8   q(natm)
      integer  ibnd(nbnd),jbnd(nbnd),ifix(nfix)
      real*8   fb,fx
      integer  ndim,natm,nbnd,nfix
      real*8   e,de(natm,ndim)
c
      integer i,j,ii,jj
      real*8 dx,dy,dz,zi,dr,rij,rij0,rij2,rij4,gx,gy,gz,fc,fc2,fc4,qu
c
      qu=505.4
c
      e=0.0
      do i=1,natm
          de(i,1)=0.0
          de(i,2)=0.0
          de(i,3)=0.0
      enddo
c     fix atom potential
      fc=2.0*fx
      do i=1,nfix
          ii=ifix(i)+1
          if (ii .le. 0) exit
          dx=cc(ii,1)-ccfix(i,1)
          dy=cc(ii,2)-ccfix(i,2)
          dz=cc(ii,3)-ccfix(i,3)
          e=e+fx*(dx*dx+dy*dy+dz*dz)
          de(ii,1)=de(ii,1)+fc*dx
          de(ii,2)=de(ii,2)+fc*dy
          de(ii,3)=de(ii,3)+fc*dz
      enddo
c     subtract charge interactions between fixed atoms
      do i=1,nfix-1
          ii=ifix(i)+1
          do j=i+1,nfix
              jj=ifix(j)+1
              dx=cc(ii,1)-cc(jj,1)
              dy=cc(ii,2)-cc(jj,2)
              dz=cc(ii,3)-cc(jj,3)
              rij2=dx*dx+dy*dy+dz*dz
              rij=sqrt(rij2)
              fc=qu*q(ii)*q(jj)
              e=e-fc/rij
              fc=-1.0*fc/(rij2*rij)
              gx=fc*dx
              gy=fc*dy
              gz=fc*dz
              de(ii,1)=de(ii,1)-gx
              de(ii,2)=de(ii,2)-gy
              de(ii,3)=de(ii,3)-gz
              de(jj,1)=de(jj,1)+gx
              de(jj,2)=de(jj,2)+gy
              de(jj,3)=de(jj,3)+gz
          enddo
      enddo
c     charge-charge interactions
      do i=1,natm-1
          do j=i+1,natm
              dx=cc(i,1)-cc(j,1)
              dy=cc(i,2)-cc(j,2)
              dz=cc(i,3)-cc(j,3)
              rij2=dx*dx+dy*dy+dz*dz
              rij=sqrt(rij2)
              fc=qu*q(i)*q(j)
              e=e+fc/rij
              fc=-1.0*fc/(rij2*rij)
              gx=fc*dx
              gy=fc*dy
              gz=fc*dz
              de(i,1)=de(i,1)+gx
              de(i,2)=de(i,2)+gy
              de(i,3)=de(i,3)+gz
              de(j,1)=de(j,1)-gx
              de(j,2)=de(j,2)-gy
              de(j,3)=de(j,3)-gz
          enddo
      enddo
c     bond term ... fb*(r-r0)**2
      do i=1,nbnd
          ii=ibnd(i)+1
          jj=jbnd(i)+1
          rij0=rbnd(i)
          dx=cc(ii,1)-cc(jj,1)
          dy=cc(ii,2)-cc(jj,2)
          dz=cc(ii,3)-cc(jj,3)
          rij2=dx*dx+dy*dy+dz*dz
          rij=sqrt(rij2)
          dr=rij-rij0
          e=e+fb*dr*dr
          fc=2.0*fb*dr/rij
          gx=fc*dx
          gy=fc*dy
          gz=fc*dz
          de(ii,1)=de(ii,1)+gx
          de(ii,2)=de(ii,2)+gy
          de(ii,3)=de(ii,3)+gz
          de(jj,1)=de(jj,1)-gx
          de(jj,2)=de(jj,2)-gy
          de(jj,3)=de(jj,3)-gz
c         subtract contribution of bonds to cgarhe-charge int
          fc=qu*q(ii)*q(jj)
          e=e-fc/rij
          fc=-1.0*fc/(rij2*rij)
          gx=fc*dx
          gy=fc*dy
          gz=fc*dz
          de(ii,1)=de(ii,1)-gx
          de(ii,2)=de(ii,2)-gy
          de(ii,3)=de(ii,3)-gz
          de(jj,1)=de(jj,1)+gx
          de(jj,2)=de(jj,2)+gy
          de(jj,3)=de(jj,3)+gz
      enddo

      return
      end


#include "scalar.fpp"

!=====================================================================!
! Crank Nicolson integration module for differential equations.
!
! Author: Komahan Boopathy (komahan@gatech.edu)
!=====================================================================!

module crank_nicolson_integrator_class

  use integrator_interface      , only : integrator
  use dynamic_physics_interface , only : dynamics
  use utils, only : real_part

  implicit none

  private
  public :: CNI

  !===================================================================!
  ! CNI Integrator type
  !===================================================================!

  type, extends(integrator) :: CNI

     private

     ! CNI variables
     type(integer)             :: max_order = 6
     type(scalar), allocatable :: A(:,:)

   contains

     procedure :: step
     procedure :: get_linearization_coeff
     procedure :: get_bandwidth

     ! Destructor
     final :: destroy

  end type CNI

  interface CNI
     module procedure create
  end interface CNI

contains

  !===================================================================!
  ! Initialize the CNI datatype and allocate required variables
  !===================================================================!

  type(cni) function create(system, tinit, tfinal, h, implicit, &
       & accuracy_order) result(this)

    class(dynamics)   , intent(in)   , target :: system
    type(scalar)      , intent(in)            :: tinit, tfinal
    type(scalar)      , intent(in)            :: h
    type(integer)     , intent(in)            :: accuracy_order
    type(logical)     , intent(in)            :: implicit

    print *, "======================================"
    print *, ">>   Backward Difference Formulas  << "
    print *, "======================================"

    call this % construct(system, tinit, tfinal, h, implicit, num_stages=0)

    !-----------------------------------------------------------------!
    ! Set the order of integration
    !-----------------------------------------------------------------!

    if (accuracy_order .le. this % max_order) this % max_order = accuracy_order
    print '("  >> Max CNI Order        : ",i4)', this % max_order

    allocate( this % A (this % max_order, this % max_order+1) )
    this % A = 0.0d0

    ! Set the coefficients
    ! http://www.scholarpedia.org/article/Backward_differentiation_formulas
    if ( this % max_order .ge. 1 ) this % A(1,1:2) = [1.0d0, -1.0d0]
    if ( this % max_order .ge. 2 ) this % A(2,1:3) = [3.0d0, -4.0d0, 1.0d0]/2.0d0
    if ( this % max_order .ge. 3 ) this % A(3,1:4) = [11.0d0, -18.0d0, 9.0d0, -2.0d0]/6.0d0
    if ( this % max_order .ge. 4 ) this % A(4,1:5) = [25.0d0, -48.0d0, 36.0d0, -16.0d0, 3.0d0]/12.0d0
    if ( this % max_order .ge. 5 ) this % A(5,1:6) = [137.0d0, -300.0d0, 300.0d0, -200.0d0, 75.0d0, -12.0d0]/60.0d0
    if ( this % max_order .ge. 6 ) this % A(6,1:7) = [147.0d0, -360.0d0, 450.0d0, -400.0d0, 225.0d0, -72.0d0, 10.0d0]/60.0d0

    ! Sanity check on CNI coeffs
    sanity_check: block
      type(integer) :: j
      do j = 1, this % max_order
         if (abs(sum(real_part(this % A(j,1:j+1)))) .gt. 1.0d-15 ) then
            print *, "Error in CNI Coeff for order ", abs(sum(real_part(this % A(j,1:j+1)))), j
            stop
         end if
      end do
    end block sanity_check

  end function create

  !=================================================================!
  ! Destructor for the CNI integrator
  !=================================================================!

  pure subroutine destroy(this)

    type(CNI), intent(inout) :: this

    ! Parent class call
    call this % destruct()

    ! Deallocate CNI coefficient
    if(allocated(this % A)) deallocate(this % A)

  end subroutine destroy

  !===================================================================!
  ! Returns the order of approximation for the given time step k and
  ! degree d
  !===================================================================!

  pure type(integer) function get_bandwidth(this, time_index) result(width)

    class(CNI)   , intent(in) :: this
    type(integer), intent(in) :: time_index

    width = time_index - 1

    if (width .gt. this % max_order) width = this % max_order

  end function get_bandwidth

  !================================================================!
  ! Take a time step using the supplied time step and order of
  ! accuracy
  ! ================================================================!

  impure subroutine step(this, t, u, h, p, ierr)

    use nonlinear_algebra, only : solve

    ! Argument variables
    class(CNI)   , intent(inout) :: this
    type(scalar) , intent(inout) :: t(:)
    type(scalar) , intent(inout) :: u(:,:,:)
    type(integer), intent(in)    :: p
    type(scalar) , intent(in)    :: h
    type(integer), intent(out)   :: ierr

    ! Local variables
    type(scalar), allocatable :: lincoeff(:)  ! order of equation + 1
    type(integer) :: torder, n, i, k
    type(scalar)  :: scale
    type(scalar), allocatable, dimension(:) :: res

    ! Determine remaining paramters needed
    k = size(u(:,1,1))
    torder = this % system % get_differential_order()

    ! Advance the time to next step
    t(k) = t(k-1) + h

    ! Assume a value for lowest order state
    u(k,1,:) = 0.0d0

    ! Find the higher order states based on CNI formula
    do n = 1, torder
       do i = 0, p
          scale = this % A(p,i+1)/h !(t(k-i)-t(k-i-1))
          u(k,n+1,:) = u(k,n+1,:) + scale*u(k-i,n,:)
       end do
    end do

    ! Perform a nonlinear solution if this is a implicit method
    if ( this % implicit ) then

       allocate(lincoeff(torder+1))
       call this % get_linearization_coeff(p, h, lincoeff)
       call solve(this % system, lincoeff, t(k), u(k,:,:), this % X)
       deallocate(lincoeff)

    else

       ! Figure out the best way?  (a) do no pass in the implicit
       ! terms and this requires the user to be aware of whether
       ! implicit or explicit marching is used.
       ! Explicit Euler
       ! (extend for arbitrary order)

       ! What if phi and phidot are coupled i.e. nonlinear?

       if (.not. allocated(res)) allocate(res(this % system % get_num_state_vars()))

       ! Fixed point iteration? might ignore coupled terms?

       ! R = R_phidot + R_phi
       res = 0.0d0

       ! No solve necesary. Just linear combinations
       u(k,1,:) = u(k-1,1,:)

       ! Evaluate residual at new phidot and old phi
       call this % system % add_residual(res, U(k,:,:), this % X)

       ! Subtract the newphidot from res (actually res(phidot)
       u(k,1,:) = u(k-1,1,:) + h*(U(k,2,:)-res)

       deallocate(res)

    end if

  end subroutine step

  !================================================================!
  ! Retrieve the coefficients for linearizing the jacobian
  !================================================================!

  pure subroutine get_linearization_coeff(this, cindex, h, lincoeff)

    class(CNI)    , intent(in)    :: this
    type(integer) , intent(in)    :: cindex
    type(scalar)  , intent(in)    :: h
    type(scalar)  , intent(inout) :: lincoeff(:)

    type(integer) :: n

    associate( &
         & deriv_order => this % system % get_differential_order(), &
         & a => this % A(cindex,1))

    forall(n=0:deriv_order)
       lincoeff(n+1) = (a/h)**n
    end forall

  end associate

end subroutine get_linearization_coeff

end module crank_nicolson_integrator_class


module a_01
implicit none

type :: X
    real :: r
    integer :: i
end type

type :: Y
    complex :: c
    type(X) :: d
end type

contains

subroutine set(a)
type(X), intent(out) :: a
a%i = 1
a%r = 1.5
end subroutine

end module

module a_02
use a_01, only: Y
implicit none

type :: Z
    complex :: k
    type(Y) :: l
end type

end module

program derived_types_01
use a_02, only: Z
use a_01, only: X, set
implicit none
type(X) :: b
type(Z) :: c
b%i = 5
b%r = 3.5
print *, b%i, b%r
call set(b)
print *, b%i, b%r
c%l%d%r = 2.0
c%l%d%i = 2
c%k = (2.0, 2.0)
print *, c%l%d%r, c%l%d%i, c%k
call set(c%l%d)
print *, c%l%d%r, c%l%d%i, c%k
end


subroutine sigma_function(latitude,lhour,dayear,altitude,fpsolar,kpindex,stdev)

    ! last version updated : 05/01/2021
    ! Author : Claude Boniface (CNES)

    !----------------------------------!
    ! ONE-SIGMA ERROR EVALUATION MODULE!
    !----------------------------------!

    ! The model is well justified in the range [200 km - 500 km].
    ! However, strong assumptions must be added to extend the altitude range from 100 km to 1000 km due to unavailability of data:
    ! at lower altitudes (< 200 km), a worst-case is chosen by fixing the evolution of 1-sigma to their values at the altitude of 200 km,
    ! at higher altitudes (> 500 km), an optimistic case is assumed by keeping the evolution of 1-sigma for the altitude of 500 km.

    !     latitude= latitude (in deg, -90;90)
    !     lhour   = local time (in hr, 0-24)
    !     dayear  = day of year (1-366)
    !     altitude= altitude (in km) greater than 120 km
    !     fpsolar = mean flux of last 81 days at t   =   fbar(1)
    !     kpindex = kp delayed by 3 hours = akp(1)

    !----------------------!
    ! DECLARATION VARIABLES!
    !----------------------!

    implicit none
    real :: latitude, lhour, dayear, altitude, fpsolar, kpindex, stdev ! argument parameter values
    real :: Copt_L, Copt_M, Copt_H ! projection coefficient in hyperplane equations
    real :: Res_L, Res_M, Res_H    ! direction coefficient in hyperplane equations
    real :: stdev_L, stdev_M, stdev_H  ! sigma values at different range of altitude
    ! sigma at low altitude (sigma < 200 km)
    real :: sigma_FP_L ! 1-sigma (Fp proxy)
    real :: sigma_KP_L ! 1-sigma (Kp index)
    real :: sigma_alat_L  !1-sigma in latitude
    real :: sigma_hl_L    !1-sigma in local hour
    real :: sigma_day_L   ! 1-sigma in day of year
    real :: sigma_alti_L  ! 1-sigma in altitude
    ! sigma at middle altitude (200 km <= sigma =< 500 km)
    real :: sigma_FP_M ! 1-sigma (Fp proxy)
    real :: sigma_KP_M ! 1-sigma (Kp index)
    real :: sigma_alat_M  !1-sigma in latitude
    real :: sigma_hl_M    !1-sigma in local hour
    real :: sigma_day_M   ! 1-sigma in day of year
    real :: sigma_alti_M  ! 1-sigma in altitude
    ! sigma at high altitude (sigma > 500 km)
    real :: sigma_FP_H ! 1-sigma (Fp proxy)
    real :: sigma_KP_H ! 1-sigma (Kp index)
    real :: sigma_alat_H  !1-sigma in latitude
    real :: sigma_hl_H    !1-sigma in local hour
    real :: sigma_day_H   ! 1-sigma in day of year
    real :: sigma_alti_H  ! 1-sigma in altitude

    !-----------------------!
    ! ONE-SIGMA CALCULATIONS!
    !-----------------------!

    altit : If(altitude.LT.200) then

        ! Global 1-sigma calculation by means of statistical binning of data (GOCE, CHAMP, GRACE and SWARM) and Hyperplan equation (6 dimensions)
	! Polynomial extrapolation by fixing altitude value at 200 km

        Copt_L = 0.929
        Res_L = 112.79
        sigma_alat_L = std_alat_M(latitude)
        sigma_hl_L = std_hl_M(lhour)
        sigma_day_L = std_day_M(dayear)
        sigma_alti_L = std_alti_M(200.)
        sigma_FP_L = std_FP_M(fpsolar)
        sigma_KP_L = std_KP_M(kpindex)

        stdev = sigma_alat_L + sigma_hl_L + sigma_day_L + sigma_alti_L + sigma_FP_L + sigma_KP_L + Copt_L - Res_L

    ElseIf(altitude.GE.200.AND.altitude.LE.500) then

        ! Global 1-sigma calculation by means of statistical binning data (GOCE, CHAMP, GRACE and SWARM)) and Hyperplan equation (6 dimensions)
	! Polynomial interpolation

        Copt_M = 0.929
        Res_M = 112.79
        sigma_alat_M = std_alat_M(latitude)
        sigma_hl_M = std_hl_M(lhour)
        sigma_day_M = std_day_M(dayear)
        sigma_alti_M = std_alti_M(altitude)
        sigma_FP_M = std_FP_M(fpsolar)
        sigma_KP_M = std_KP_M(kpindex)

        stdev = sigma_alat_M + sigma_hl_M + sigma_day_M + sigma_alti_M + sigma_FP_M + sigma_KP_M + Copt_M - Res_M

    ElseIf(altitude.GT.500) then

        ! Global 1-sigma calculation by means of statistical binning data (GOCE, CHAMP, GRACE and SWARM) and Hyperplan equation (6 dimensions)
	! Polynomial extrapolation by fixing altitude value at 500 km

        Copt_H = 0.929
        Res_H = 112.79
        sigma_alat_H = std_alat_M(latitude)
        sigma_hl_H = std_hl_M(lhour)
        sigma_day_H = std_day_M(dayear)
        sigma_alti_H = std_alti_M(500.)
        sigma_FP_H = std_FP_M(fpsolar)
        sigma_KP_H = std_KP_M(kpindex)

        stdev = sigma_alat_H + sigma_hl_H + sigma_day_H + sigma_alti_H + sigma_FP_H + sigma_KP_H + Copt_H - Res_H

    Endif altit

contains

    !--------------------!
    ! ANALYTICAL FUNCTONS!
    !--------------------!

    ! General polynomial function

    function std_poly(x,n,a)
        integer :: h
        real :: std_poly
        integer, intent(in) :: n
        real, intent(in) :: x
        real, dimension(0:n) :: a
        h = 0
        std_poly = 0.
        Do h = 0,n
            std_poly = std_poly + a(h)*x**(h)
        enddo
    end function

    ! Solar Flux Fp
    !--------------

    function std_FP_M(x)
        real :: std_FP_M
        real, intent(in) :: x
        integer :: d
        real, dimension(0:1) :: c
        d = 1
        c(0) = 26.04
        c(1) = -3.36e-2
        std_FP_M = std_poly(x,d,c)
    end function std_FP_M

    ! Magnetic index Kp
    !------------------

    function std_KP_M(x)
        real :: std_KP_M
        real, intent(in) :: x
        integer :: d
        real, dimension(0:3) :: c
        d = 3
        c(0) = 22.47
        c(1) = 7.46e-1
        c(2) = -1.99e-1
        c(3) = 6.56e-2
        std_KP_M = std_poly(x,d,c)
    end function std_KP_M

    ! Latitude
    !---------

    function std_alat_M(x)
        real :: std_alat_M
        real, intent(in) :: x
        integer :: d
        real, dimension(0:2) :: c
        d = 2
        c(0) = 22.33
        c(1) = -7.19e-3
        c(2) = 4.72e-4
        std_alat_M = std_poly(x,d,c)
    end function std_alat_M

    ! Local hour
    !-----------

    function std_hl_M(x)
        real :: std_hl_M
        real, intent(in) :: x
        integer :: d
        real, dimension(0:3) :: c
        d = 3
        c(0) = 28.53
        c(1) = -3.95e-1
        c(2) = -5.64e-2
        c(3) = 3.15e-3
        std_hl_M = std_poly(x,d,c)
    end function std_hl_M

    ! Altitude
    !---------

    function std_alti_M(x)
        real :: std_alti_M
        real, intent(in) :: x
        integer :: d
        real, dimension(0:1) :: c
        d = 1
        c(0) = -9.73
        c(1) = 7.92e-2
        std_alti_M = std_poly(x,d,c)
    end function std_alti_M

    ! Day of year
    !------------
    ! Low solar flux regime

    function std_day_M(x)
        real :: std_day_M
        real, intent(in) :: x
        integer :: d
        real, dimension(0:1) :: c
        d = 1
        c(0) = 23.15
        c(1) = -3.91e-3
        std_day_M = std_poly(x,d,c)
    end function std_day_M

end subroutine


Subroutine n1535(lb1, lb2, srt, x1535)
  Save
  s0 = 2.424
  x1535 = 0.
  If (srt<=s0) Return
  sigma = 2.*0.102*(srt-s0)/(0.058+(srt-s0)**2)
  If ((lb1*lb2==1) .Or. (lb1==2 .And. lb2==2)) Then
     x1535 = sigma
     Return
  End If
  If (lb1*lb2==2) Then
     x1535 = 3.*sigma
     Return
  End If
  If ((lb1*lb2==63 .And. (lb1==7 .Or. lb2==7)) .Or. (lb1*lb2==64 .And. (lb1==8 .Or. lb2==8)) .Or. (lb1*lb2==48 .And. (lb1==6 .Or. lb2==6)) .Or. (lb1*lb2==49 .And. (lb1==7 .Or. lb2==7))) Then
     x1535 = sigma
     Return
  End If
  If ((lb1*lb2==54 .And. (lb1==6 .Or. lb2==6)) .Or. (lb1*lb2==56 .And. (lb1==7 .Or. lb2==7))) Then
     x1535 = 3.*sigma
     Return
  End If
  If ((lb1==10 .And. lb2==10) .Or. (lb1==11 .And. lb2==11)) x1535 = sigma
  If (lb1*lb2==110 .And. (lb1==10 .Or. lb2==10)) x1535 = 3.*sigma
  Return
End Subroutine n1535


      subroutine solve_hs3(ctfm,ctfmp,n_A,n_B,n_C1s,n_C5psi,n_psi,octfmp
     &,Nx,hx,myzero,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 hx
      real*8 myzero
      real*8 ctfm(Nx)
      real*8 ctfmp(Nx)
      real*8 n_A(Nx)
      real*8 n_B(Nx)
      real*8 n_C1s(Nx)
      real*8 n_C5psi(Nx)
      real*8 n_psi(Nx)
      real*8 octfmp(Nx)
      integer phys_bdy(2)
      real*8 res(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = 0.1333333333333333D1 * n_psi(i + 1) - 0.3333333333333333D0 *
     #n_psi(i + 2)
      res(i)=qb
      end do
      endif
      do i=2, Nx-1, 1
      qb = n_psi(i) - 0.1D1 / (n_C1s(i) * n_A(i) * ctfmp(i) ** 2 * hx **
     # 2 - 0.2D1) * n_A(i) * ctfmp(i) ** 2 * hx ** 2 * (n_C1s(i) * n_psi
     #(i) + n_C5psi(i) + (-0.5000000000000000D0 / n_A(i) / ctfmp(i) * (-
     #0.1D1 * n_psi(i - 1) + n_psi(i + 1)) * octfmp(i) + 0.1D1 / ctfm(i)
     # / n_A(i) / ctfmp(i) * (-0.1D1 * n_psi(i - 1) + n_psi(i + 1))) / h
     #x + (0.1D1 / n_A(i) * (n_psi(i - 1) - 0.2D1 * n_psi(i) + n_psi(i +
     # 1)) - 0.1250000000000000D0 / n_A(i) ** 2 * (-0.1D1 * n_A(i - 1) +
     # n_A(i + 1)) * (-0.1D1 * n_psi(i - 1) + n_psi(i + 1)) + 0.25000000
     #00000000D0 / n_B(i) / n_A(i) * (-0.1D1 * n_B(i - 1) + n_B(i + 1))
     #* (-0.1D1 * n_psi(i - 1) + n_psi(i + 1))) / ctfmp(i) ** 2 / hx **
     #2)
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = 0.1D1 - 0.1D1 * myzero * ctfm(i)
      res(i)=qb
      end do
      endif
      END


      subroutine port(x,n,e,c,io)
c********************************************
c  c - protmentau test statistic p-value
c  x - data array, n - sample size, nlg=n**e, sum2 - sum of squared cors
c============================================================
      real x(n),c,e
      real*8 cv,sum2,rn
      integer t
      intent(in) x,n,e,io
      intent(out) c
c************************
      rn=dfloat(n-1)
      nlg=nint(float(n)**e)
      rng=float(nlg)
      c=1.
      sum2=0.d0
c  Start loop on k
      do k=1,nlg
       rn=dfloat(n-k)
c  Sum x(t)*x(t+k)
        cv=0.d0
        do t=1,n-k
         cv=cv+dble(x(t))*dble(x(t+k))
        enddo
       sum2=sum2+cv/rn*cv
      enddo
c  Chi**2 for squared cors
c  Correlation statistic
      call cdchi(sngl(sum2),rng,c,io)
      c=1.-c
c--------
      return
      end


*DECK BI
      FUNCTION BI (X)
C***BEGIN PROLOGUE  BI
C***PURPOSE  Evaluate the Bairy function (the Airy function of the
C            second kind).
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10D
C***TYPE      SINGLE PRECISION (BI-S, DBI-D)
C***KEYWORDS  BAIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BI(X) calculates the Airy function of the second kind for real
C argument X.
C
C Series for BIF        on the interval -1.00000D+00 to  1.00000D+00
C                                        with weighted error   1.88E-19
C                                         log weighted error  18.72
C                               significant figures required  17.74
C                                    decimal places required  19.20
C
C Series for BIG        on the interval -1.00000D+00 to  1.00000D+00
C                                        with weighted error   2.61E-17
C                                         log weighted error  16.58
C                               significant figures required  15.17
C                                    decimal places required  17.03
C
C Series for BIF2       on the interval  1.00000D+00 to  8.00000D+00
C                                        with weighted error   1.11E-17
C                                         log weighted error  16.95
C                        approx significant figures required  16.5
C                                    decimal places required  17.45
C
C Series for BIG2       on the interval  1.00000D+00 to  8.00000D+00
C                                        with weighted error   1.19E-18
C                                         log weighted error  17.92
C                        approx significant figures required  17.2
C                                    decimal places required  18.42
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BIE, CSEVL, INITS, R1MACH, R9AIMP, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  BI
      DIMENSION BIFCS(9), BIGCS(8), BIF2CS(10), BIG2CS(10)
      LOGICAL FIRST
      SAVE BIFCS, BIGCS, BIF2CS, BIG2CS, NBIF, NBIG, NBIF2,
     1 NBIG2, X3SML, XMAX, FIRST
      DATA BIFCS( 1) /   -.0167302164 7198664948E0 /
      DATA BIFCS( 2) /    .1025233583 424944561E0 /
      DATA BIFCS( 3) /    .0017083092 5073815165E0 /
      DATA BIFCS( 4) /    .0000118625 4546774468E0 /
      DATA BIFCS( 5) /    .0000000449 3290701779E0 /
      DATA BIFCS( 6) /    .0000000001 0698207143E0 /
      DATA BIFCS( 7) /    .0000000000 0017480643E0 /
      DATA BIFCS( 8) /    .0000000000 0000020810E0 /
      DATA BIFCS( 9) /    .0000000000 0000000018E0 /
      DATA BIGCS( 1) /    .0224662232 4857452E0 /
      DATA BIGCS( 2) /    .0373647754 5301955E0 /
      DATA BIGCS( 3) /    .0004447621 8957212E0 /
      DATA BIGCS( 4) /    .0000024708 0756363E0 /
      DATA BIGCS( 5) /    .0000000079 1913533E0 /
      DATA BIGCS( 6) /    .0000000000 1649807E0 /
      DATA BIGCS( 7) /    .0000000000 0002411E0 /
      DATA BIGCS( 8) /    .0000000000 0000002E0 /
      DATA BIF2CS( 1) /   0.0998457269 3816041E0 /
      DATA BIF2CS( 2) /    .4786249778 63005538E0 /
      DATA BIF2CS( 3) /    .0251552119 604330118E0 /
      DATA BIF2CS( 4) /    .0005820693 885232645E0 /
      DATA BIF2CS( 5) /    .0000074997 659644377E0 /
      DATA BIF2CS( 6) /    .0000000613 460287034E0 /
      DATA BIF2CS( 7) /    .0000000003 462753885E0 /
      DATA BIF2CS( 8) /    .0000000000 014288910E0 /
      DATA BIF2CS( 9) /    .0000000000 000044962E0 /
      DATA BIF2CS(10) /    .0000000000 000000111E0 /
      DATA BIG2CS( 1) /    .0333056621 45514340E0 /
      DATA BIG2CS( 2) /    .1613092151 23197068E0 /
      DATA BIG2CS( 3) /    .0063190073 096134286E0 /
      DATA BIG2CS( 4) /    .0001187904 568162517E0 /
      DATA BIG2CS( 5) /    .0000013045 345886200E0 /
      DATA BIG2CS( 6) /    .0000000093 741259955E0 /
      DATA BIG2CS( 7) /    .0000000000 474580188E0 /
      DATA BIG2CS( 8) /    .0000000000 001783107E0 /
      DATA BIG2CS( 9) /    .0000000000 000005167E0 /
      DATA BIG2CS(10) /    .0000000000 000000011E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BI
      IF (FIRST) THEN
         ETA = 0.1*R1MACH(3)
         NBIF  = INITS (BIFCS , 9, ETA)
         NBIG  = INITS (BIGCS , 8, ETA)
         NBIF2 = INITS (BIF2CS, 10, ETA)
         NBIG2 = INITS (BIG2CS, 10, ETA)
C
         X3SML = ETA**0.3333
         XMAX = (1.5*LOG(R1MACH(2)))**0.6666
      ENDIF
      FIRST = .FALSE.
C
      IF (X.GE.(-1.0)) GO TO 20
      CALL R9AIMP (X, XM, THETA)
      BI = XM * SIN(THETA)
      RETURN
C
 20   IF (X.GT.1.0) GO TO 30
      Z = 0.0
      IF (ABS(X).GT.X3SML) Z = X**3
      BI = 0.625 + CSEVL (Z, BIFCS, NBIF) + X*(0.4375 +
     1  CSEVL (Z, BIGCS, NBIG))
      RETURN
C
 30   IF (X.GT.2.0) GO TO 40
      Z = (2.0*X**3 - 9.0) / 7.0
      BI = 1.125 + CSEVL (Z, BIF2CS, NBIF2) + X*(0.625 +
     1  CSEVL (Z, BIG2CS, NBIG2))
      RETURN
C
 40   IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'BI',
     +   'X SO BIG THAT BI OVERFLOWS', 1, 2)
C
      BI = BIE(X) * EXP(2.0*X*SQRT(X)/3.0)
      RETURN
C
      END


Real Function fmassn(dmass)
  Save
  am0 = 1.44
  fmassn = am0*w1440(dmass)/((dmass**2-am0**2)**2+am0**2*w1440(dmass)**2)
  Return
End Function fmassn


!
! SEISMIC_CPML Version 1.1.3, September 2015.
!
! Copyright CNRS, France.
! Contributor: Dimitri Komatitsch, komatitsch aT lma DOT cnrs-mrs DOT fr
!
! This software is a computer program whose purpose is to solve
! the two-dimensional heterogeneous acoustic wave equation
! using a finite-difference method with Convolutional Perfectly Matched
! Layer (C-PML) conditions.
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
! using a spectral-element method (SEM).
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 2 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License along
! with this program; if not, write to the Free Software Foundation, Inc.,
! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
!
! The full text of the license is available in file "LICENSE".

  program seismic_CPML_2D_pressure

! 2D acoustic finite-difference code in pressure formulation
! with Convolutional-PML (C-PML) absorbing conditions for an heterogeneous acoustic medium

! Dimitri Komatitsch, CNRS, Marseille, September 2015.

! The pressure wave equation in an inviscid heterogeneous fluid is:
!
! 1/Kappa d2p / dt2 = div(grad(p) / rho) = d(1/rho dp/dx)/dx + d(1/rho dp/dy)/dy
!
! (see for instance Komatitsch and Tromp, Geophysical Journal International, vol. 149, p. 390-412 (2002), equations (19) and (21))
!
! The second-order staggered-grid formulation of Madariaga (1976) and Virieux (1986) is used:
!
!            ^ y
!            |
!            |
!
!            +-------------------+
!            |                   |
!            |                   |
!            |                   |
!            |                   |
!            |                   |
!      dp/dy +---------+         |
!            |         |         |
!            |         |         |
!            |         |         |
!            |         |         |
!            |         |         |
!            +---------+---------+  ---> x
!            p       dp/dx

! pour afficher le resultat 2D sous forme d'image en couleurs :
!
!   " display image*.gif " ou " gimp image*.gif "
!
!   " montage -geometry +0+3 -tile 1x60 image*.gif allfiles.gif "
!   puis " display allfiles.gif " ou bien " gimp allfiles.gif "
!
! When compiling with Intel ifort, use " -assume byterecl " option to create temporary binary PNM images

  implicit none

! flags to add PML layers to the edges of the grid
  logical, parameter :: USE_PML_XMIN = .true.
  logical, parameter :: USE_PML_XMAX = .true. ! parameter attribute = a named constant (can't be altered)
  logical, parameter :: USE_PML_YMIN = .true.
  logical, parameter :: USE_PML_YMAX = .true.

! thickness of the PML layer in grid points
  integer :: NPOINTS_PML ![COMMAND LINE ARGUMENT] (sample points)   before: = 10

! total number of grid points in each direction of the grid
  integer :: NX ![COMMAND LINE ARGUMENT]  (samples)
  integer :: NY ![COMMAND LINE ARGUMENT]  (samples) (DEPTH AXIS)

! size of a grid cell
  double precision :: DELTAX ![COMMAND LINE ARGUMENT] (m)   before: = 12.5d0
  double precision :: DELTAY ![COMMAND LINE ARGUMENT] (m)   before: = DELTAX

! P-velocity, S-velocity and density
  double precision :: cp_value = 2500.d0 ! this is a double precision type  m/s
  double precision, parameter :: rho_value = 2200.d0  ! guessing this is kg/m3

! total number of time steps
  integer :: NSTEP ! [COMMAND LINE INPUT] parameter attribute means named constant

! time step in seconds
  double precision :: DELTAT ![COMMAND LINE ARGUMENT] (s)  before: = 2.d-3

! rapport DELTAT / DELTAX
  double precision :: DELTAT_OVER_DELTAX ![CALCULATED BELOW]

! parameters for the source
! tres peu de dispersion si 8 Hz, correct si 10 Hz, dispersion sur S si 12 Hz
! mauvais si 16 Hz, tres mauvais si 25 Hz
! [very little dispersion if 8 Hz, correct if 10 Hz, dispersion on S if 12 Hz
! bad if 16 Hz, very bad if 25 Hz ]
  double precision, parameter :: f0 = 20.d0
! decaler le Ricker en temps pour s'assurer qu'il est nul a t = 0
  double precision, parameter :: t0 = 1.2d0 / f0  ! shift the Ricker in time to make sure it is zero at t = 0
  double precision, parameter :: factor = 1.d4

! source in the medium
  double precision :: XSOURCE ![COMMAND LINE INPUT] (in meters)
  double precision :: YSOURCE ![COMMAND LINE INPUT] (in meters)

! receivers
  integer :: NREC !=11 [COMMAND LINE/ FILE INPUT]
  !double precision, parameter :: xdeb![COMMAND LINE/ FILE INPUT] = 100.d0   ! first receiver x in meters
  !double precision, parameter :: ydeb![COMMAND LINE/ FILE INPUT] = 2400.d0  ! first receiver y in meters
  !double precision, parameter :: xfin![COMMAND LINE/ FILE INPUT] = 3850.d0  ! last receiver x in meters
  !double precision, parameter :: yfin![COMMAND LINE/ FILE INPUT] = 2400.d0  ! last receiver y in meters

! affichage periodique d'informations a l'ecran
  integer, parameter :: IT_AFFICHE = 10  ! periodic display of information on the screen

! zero
  double precision, parameter :: ZERO = 0.d0

! large value for maximum
  double precision, parameter :: HUGEVAL = 1.d+30

! pressure threshold above which we consider the code became unstable
  double precision, parameter :: STABILITY_THRESHOLD = 1.d+25

! valeur de PI
  double precision, parameter :: PI = 3.141592653589793238462643d0

! main arrays
  double precision, allocatable :: xgrid(:,:),ygrid(:,:), & ! (NX, NY) DYNAMICALLY ALLOCATE THIS AFTER COMMAND LINE INPUT
      pressurepast(:,:),pressurepresent(:,:),pressurefuture(:,:), &
      pressure_xx(:,:),pressure_yy(:,:),dpressurexx_dx(:,:),dpressureyy_dy(:,:),kappa(:,:),cp(:,:),rho(:,:)

! for seismograms
  double precision, allocatable :: sispressure(:,:) !(NSTEP,NREC) DYNAMICALLY ALLOCATE THIS AFTER COMMAND LINE INPUT

! for source
  integer i_source,j_source
  double precision a,t,force_x,force_y

  integer, allocatable :: i_sources(:), j_sources(:) ![COMMAND LINE/ FILE INPUT]
  integer NSOURCES ![COMMAND LINE/ FILE INPUT]
  logical sourcefilecheck
  character(len=512) :: SOURCE_FILE ![COMMAND LINE ARGUMENT]

! for receivers
  !double precision xspacerec,yspacerec
  double precision distval,dist
  integer, allocatable :: ix_rec(:), iy_rec(:)
  !double precision, allocatable :: xrec(:), yrec(:)

  integer i,j,it,irec

  double precision nombre_Courant,pressure_max_all

! power to compute d0 profile
  double precision, parameter :: NPOWER = 2.d0

! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-11
  double precision, parameter :: K_MAX_PML = 1.d0
  double precision, parameter :: ALPHA_MAX_PML = 2.d0*PI*(f0/2.d0) ! from Festa and Vilotte

! arrays for the memory variables
! could declare these arrays in PML only to save a lot of memory, but proof of concept only here
  double precision, allocatable :: & ! (NX, NY) DYNAMICALLY ALLOCATE THIS AFTER COMMAND LINE INPUT
      memory_dpressure_dx(:,:), &
      memory_dpressure_dy(:,:), &
      memory_dpressurexx_dx(:,:), &
      memory_dpressureyy_dy(:,:)

  double precision :: &
      value_dpressure_dx, &
      value_dpressure_dy, &
      value_dpressurexx_dx, &
      value_dpressureyy_dy

! 1D arrays for the damping profiles
  double precision, allocatable :: d_x(:),K_x(:),alpha_prime_x(:),a_x(:),b_x(:),d_x_half(:),K_x_half(:), &
  alpha_prime_x_half(:),a_x_half(:),b_x_half(:)! (NX) DYNAMICALLY ALLOCATE THIS AFTER COMMAND LINE INPUT
  double precision, allocatable :: d_y(:),K_y(:),alpha_prime_y(:),a_y(:),b_y(:),d_y_half(:),K_y_half(:), &
  alpha_prime_y_half(:),a_y_half(:),b_y_half(:)! (NY) DYNAMICALLY ALLOCATE THIS AFTER COMMAND LINE INPUT

  double precision :: thickness_PML_x,thickness_PML_y,xoriginleft,xoriginright,yoriginbottom,yorigintop
  double precision :: Rcoef,d0_x,d0_y,xval,yval,abscissa_in_PML,abscissa_normalized

character(len=512) :: VELOCITY_FILE ![COMMAND LINE ARGUMENT]  m/s
character(len=512) :: OUT_DIR ![COMAND LINE ARGUMENT]
integer :: SIM_NUM ![COMMAND LINE ARGUMENT]
character(len=512) :: RECEIVER_FILE ![COMAND LINE ARGUMENT]
logical receiverfilecheck

character(len=512) :: command_arg ! for using command line inputs
integer :: filei, filej ! checks for importing velocity file

integer :: OUTPUT_WAVEFIELD ! [COMMAND LINE ARGUMENT]

!--- GET COMMAND LINE ARGUMENTS

if (command_argument_count()/=15) then
  print *, "ERROR: number of command line arguments must equal 15"

  print *, "NSTEP <int>",char(10),"&
  &NX <int>",char(10)," &
  &NY <int>",char(10)," &
  &DELTAX (m) <double precision>",char(10)," &
  &DELTAY (m) <double precision>",char(10)," &
  &DELTAT (s) <double precision>",char(10)," &
  &NPOINTS_PML <int>",char(10)," &
  &XSOURCE (m) <double precision>",char(10)," &
  &YSOURCE (m) <double precision>",char(10)," &
  &SOURCE_FILE <path>",char(10)," &
  &VELOCITY_FILE (m/s) <path>",char(10)," &
  &OUT_DIR <char>",char(10)," &
  &SIM_NUM <int>",char(10)," &
  &RECEIVER_FILE <path>",char(10)," &
  &OUTPUT_WAVEFIELD <0,1>",char(10)
  stop
end if

  do i = 1, command_argument_count()

    call get_command_argument(i, command_arg)

    if (i==1) then
    read (command_arg,*) NSTEP
    write(*,*) "NSTEP: ", NSTEP
    end if

    if (i==2) then
    read (command_arg,*) NX
    write(*,*) "NX: ", NX
    end if

    if (i==3) then
    read (command_arg,*) NY
    write(*,*) "NY: ", NY
    end if

    if (i==4) then
    read (command_arg,*) DELTAX
    write(*,*) "DELTAX: ", DELTAX
    end if

    if (i==5) then
    read (command_arg,*) DELTAY
    write(*,*) "DELTAY: ", DELTAY
    end if

    if (i==6) then
    read (command_arg,*) DELTAT
    write(*,*) "DELTAT: ", DELTAT
    end if

    if (i==7) then
    read (command_arg,*) NPOINTS_PML
    write(*,*) "NPOINTS_PML: ", NPOINTS_PML
    end if

    if (i==8) then
    read (command_arg,*) XSOURCE
    write(*,*) "XSOURCE: ", XSOURCE
    end if

    if (i==9) then
    read (command_arg,*) YSOURCE
    write(*,*) "YSOURCE: ", YSOURCE
    end if

    if (i==10) then
    SOURCE_FILE = command_arg
    write(*,*) "SOURCE_FILE: ", SOURCE_FILE
    end if

    if (i==11) then
    VELOCITY_FILE = command_arg
    write(*,*) "VELOCITY_FILE: ", VELOCITY_FILE
    end if

    if (i==12) then
    OUT_DIR = command_arg
    write(*,*) "OUT_DIR: ", OUT_DIR
    end if

    if (i==13) then
    read (command_arg,*) SIM_NUM
    write(*,*) "SIM_NUM: ", SIM_NUM
    end if

    if (i==14) then
    RECEIVER_FILE = command_arg
    write(*,*) "RECEIVER_FILE: ", RECEIVER_FILE
    end if

    if (i==15) then
    read (command_arg,*) OUTPUT_WAVEFIELD
    write(*,*) "OUTPUT_WAVEFIELD: ", OUTPUT_WAVEFIELD
    end if

  end do

! OPTIONAL ARGUMENTS

! READ SOURCE I,Js from FILE
inquire( file=SOURCE_FILE, exist=sourcefilecheck)
if (sourcefilecheck) then
  print *, "Importing source file.."
  open (77, file=SOURCE_FILE, status='old')! assume file exists (raise error otherwise)
  read(77,*) NSOURCES
  allocate(i_sources(NSOURCES))
  allocate(j_sources(NSOURCES))
  do i = 1,NSOURCES
    read(77,*) i_sources(i), j_sources(i)
    print *, i,": ",i_sources(i),",",j_sources(i)
  end do
  close(77)
else
  NSOURCES = 1
  allocate(i_sources(1))
  allocate(j_sources(1))
end if
print *,"NSOURCES: ",NSOURCES

! define location of receivers from file
inquire( file=RECEIVER_FILE, exist=receiverfilecheck)
if (receiverfilecheck) then
  print *, "Importing receiver file.."
  open (78, file=RECEIVER_FILE, status='old')! assume file exists (raise error otherwise)
  read(78,*) NREC
  allocate(ix_rec(NREC))
  allocate(iy_rec(NREC))
  do i = 1,NREC
    read(78,*) ix_rec(i), iy_rec(i)
    print *, i,": ",ix_rec(i),",",iy_rec(i)
  end do
  close(78)
else
  NREC = 1
  allocate(ix_rec(NREC))
  allocate(iy_rec(NREC))
  ix_rec(1) = 1
  iy_rec(1) = 1
end if
print *,"NREC: ",NREC

! dynamic allocations
allocate(sispressure(NSTEP,NREC))  ! allocate dynamic arrays

allocate(xgrid(NX,NY))! NB ALL WIDTH, HEIGHT
allocate(ygrid(NX,NY))
allocate(pressurepast(NX,NY))
allocate(pressurepresent(NX,NY))
allocate(pressurefuture(NX,NY))
allocate(pressure_xx(NX,NY))
allocate(pressure_yy(NX,NY))
allocate(dpressurexx_dx(NX,NY))
allocate(dpressureyy_dy(NX,NY))
allocate(kappa(NX,NY))
allocate(cp(NX,NY))
allocate(rho(NX,NY))

allocate(memory_dpressure_dx(NX,NY))
allocate(memory_dpressure_dy(NX,NY))
allocate(memory_dpressurexx_dx(NX,NY))
allocate(memory_dpressureyy_dy(NX,NY))

allocate(d_x(NX))
allocate(K_x(NX))
allocate(alpha_prime_x(NX))
allocate(a_x(NX))
allocate(b_x(NX))
allocate(d_x_half(NX))
allocate(K_x_half(NX))
allocate(alpha_prime_x_half(NX))
allocate(a_x_half(NX))
allocate(b_x_half(NX))

allocate(d_y(NY))
allocate(K_y(NY))
allocate(alpha_prime_y(NY))
allocate(a_y(NY))
allocate(b_y(NY))
allocate(d_y_half(NY))
allocate(K_y_half(NY))
allocate(alpha_prime_y_half(NY))
allocate(a_y_half(NY))
allocate(b_y_half(NY))

! dynamic variables
DELTAT_OVER_DELTAX = DELTAT / DELTAX

!---
!--- program starts here
!---

  print *
  print *,'2D acoustic finite-difference code in pressure formulation'
  print *

! create the mesh of grid points
  do j = 1,NY
    do i = 1,NX
      xgrid(i,j) = DELTAX * dble(i-1)
      ygrid(i,j) = DELTAY * dble(j-1)
    enddo
  enddo

! IMPORT VELOCITY MODEL
open (2, file=VELOCITY_FILE, status='old')! assume file exists (raise error otherwise)

! compute the Lame parameters and density
  do j = 1,NY
    do i = 1,NX

      ! IMPORT VELOCITY MODEL
      read(2,*) filei, filej, cp_value
      if (filei /= i .or. filej/= j) then
        close(2)
        print *, filei, i, filej, j, cp_value
        stop "ERROR: velocity model file does not match modelling params!"
      end if

! one can change the values of the density and P velocity model here to make it heterogeneous
      cp(i,j) = cp_value
      rho(i,j) = rho_value

      kappa(i,j) = rho(i,j)*cp(i,j)*cp(i,j)
    enddo
  enddo

close(2)

! find closest grid point for the source
  dist = HUGEVAL
  do j=1,NY
    do i=1,NX
      distval = sqrt((xgrid(i,j)-XSOURCE)**2 + (ygrid(i,j)-YSOURCE)**2)
      if(distval < dist) then
        dist = distval
        i_source = i
        j_source = j
      endif
    enddo
  enddo
  print *,'closest grid point for the source found at distance ',dist,' in i,j = ',i_source,j_source

! define location of receivers (done above..)
!  print *
!  print *,'There are ',NREC,' receivers'
!  print *
!  xspacerec = (xfin-xdeb) / dble(NREC-1)
!  yspacerec = (yfin-ydeb) / dble(NREC-1)
!  do irec=1,NREC
!    xrec(irec) = xdeb + dble(irec-1)*xspacerec ! i.e. straight line gather...
!    yrec(irec) = ydeb + dble(irec-1)*yspacerec
!  enddo

! find closest grid point for each receiver
!  do irec=1,NREC
!    dist = HUGEVAL
!    do j = 1,NY
!    do i = 1,NX
!      distval = sqrt((xgrid(i,j)-xrec(irec))**2 + (ygrid(i,j)-yrec(irec))**2)
!      if(distval < dist) then
!        dist = distval
!        ix_rec(irec) = i
!        iy_rec(irec) = j
!      endif
!    enddo
!    enddo
!    print *,'closest grid point for receiver ',irec,' found at distance ',dist,' in i,j = ',ix_rec(irec),iy_rec(irec)
!  enddo

! afficher la taille du modele   show the size of the model
  print *
  print *,'taille du modele suivant X = ',maxval(xgrid)
  print *,'taille du modele suivant Y = ',maxval(ygrid)
  print *

! verifier que la condition de stabilite de Courant est respectee
! verify that the current stability condition is met
! R. Courant et K. O. Friedrichs et H. Lewy (1928)
  nombre_Courant = maxval(cp) * DELTAT_OVER_DELTAX
  print *,'le nombre de Courant vaut ',nombre_Courant
  print *
  if(nombre_Courant > 1.d0/sqrt(2.d0)) then
    stop 'le pas de temps est trop grand, simulation instable'  ! the time step is too big, unstable simulation
  endif

! initialiser les tableaux
  pressurepresent(:,:) = ZERO
  pressurepast(:,:) = ZERO

! initialiser sismogrammes
  sispressure(:,:) = ZERO

! PML
  memory_dpressure_dx(:,:) = ZERO
  memory_dpressure_dy(:,:) = ZERO
  memory_dpressurexx_dx(:,:) = ZERO
  memory_dpressureyy_dy(:,:) = ZERO

!--- define profile of absorption in PML region

! thickness of the PML layer in meters
  thickness_PML_x = NPOINTS_PML * DELTAX
  thickness_PML_y = NPOINTS_PML * DELTAY

! reflection coefficient (INRIA report section 6.1) http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf
  Rcoef = 0.001d0

! check that NPOWER is okay
  if(NPOWER < 1) stop 'NPOWER must be greater than 1'

! compute d0 from INRIA report section 6.1 http://hal.inria.fr/docs/00/07/32/19/PDF/RR-3471.pdf
  d0_x = - (NPOWER + 1) * maxval(cp) * log(Rcoef) / (2.d0 * thickness_PML_x)
  d0_y = - (NPOWER + 1) * maxval(cp) * log(Rcoef) / (2.d0 * thickness_PML_y)

  print *,'d0_x = ',d0_x
  print *,'d0_y = ',d0_y
  print *

  d_x(:) = ZERO
  d_x_half(:) = ZERO
  K_x(:) = 1.d0
  K_x_half(:) = 1.d0
  alpha_prime_x(:) = ZERO
  alpha_prime_x_half(:) = ZERO
  a_x(:) = ZERO
  a_x_half(:) = ZERO

  d_y(:) = ZERO
  d_y_half(:) = ZERO
  K_y(:) = 1.d0
  K_y_half(:) = 1.d0
  alpha_prime_y(:) = ZERO
  alpha_prime_y_half(:) = ZERO
  a_y(:) = ZERO
  a_y_half(:) = ZERO

! damping in the X direction

! origin of the PML layer (position of right edge minus thickness, in meters)
  xoriginleft = thickness_PML_x
  xoriginright = (NX-1)*DELTAX - thickness_PML_x

  do i = 1,NX

! abscissa of current grid point along the damping profile
    xval = DELTAX * dble(i-1)

!---------- left edge
    if(USE_PML_XMIN) then

! define damping profile at the grid points
      abscissa_in_PML = xoriginleft - xval
      if(abscissa_in_PML >= ZERO) then
        abscissa_normalized = abscissa_in_PML / thickness_PML_x
        d_x(i) = d0_x * abscissa_normalized**NPOWER
! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2
        K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER
        alpha_prime_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)
      endif

! define damping profile at half the grid points
      abscissa_in_PML = xoriginleft - (xval + DELTAX/2.d0)
      if(abscissa_in_PML >= ZERO) then
        abscissa_normalized = abscissa_in_PML / thickness_PML_x
        d_x_half(i) = d0_x * abscissa_normalized**NPOWER
! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2
        K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER
        alpha_prime_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)
      endif

    endif

!---------- right edge
    if(USE_PML_XMAX) then

! define damping profile at the grid points
      abscissa_in_PML = xval - xoriginright
      if(abscissa_in_PML >= ZERO) then
        abscissa_normalized = abscissa_in_PML / thickness_PML_x
        d_x(i) = d0_x * abscissa_normalized**NPOWER
! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2
        K_x(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER
        alpha_prime_x(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)
      endif

! define damping profile at half the grid points
      abscissa_in_PML = xval + DELTAX/2.d0 - xoriginright
      if(abscissa_in_PML >= ZERO) then
        abscissa_normalized = abscissa_in_PML / thickness_PML_x
        d_x_half(i) = d0_x * abscissa_normalized**NPOWER
! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2
        K_x_half(i) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER
        alpha_prime_x_half(i) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)
      endif

    endif

! just in case, for -5 at the end
    if(alpha_prime_x(i) < ZERO) alpha_prime_x(i) = ZERO
    if(alpha_prime_x_half(i) < ZERO) alpha_prime_x_half(i) = ZERO

    b_x(i) = exp(- (d_x(i) / K_x(i) + alpha_prime_x(i)) * DELTAT)
    b_x_half(i) = exp(- (d_x_half(i) / K_x_half(i) + alpha_prime_x_half(i)) * DELTAT)

! this to avoid division by zero outside the PML
    if(abs(d_x(i)) > 1.d-6) a_x(i) = d_x(i) * (b_x(i) - 1.d0) / (K_x(i) * (d_x(i) + K_x(i) * alpha_prime_x(i)))
    if(abs(d_x_half(i)) > 1.d-6) a_x_half(i) = d_x_half(i) * &
      (b_x_half(i) - 1.d0) / (K_x_half(i) * (d_x_half(i) + K_x_half(i) * alpha_prime_x_half(i)))

  enddo

! damping in the Y direction

! origin of the PML layer (position of right edge minus thickness, in meters)
  yoriginbottom = thickness_PML_y
  yorigintop = (NY-1)*DELTAY - thickness_PML_y

  do j = 1,NY

! abscissa of current grid point along the damping profile
    yval = DELTAY * dble(j-1)

!---------- bottom edge
    if(USE_PML_YMIN) then

! define damping profile at the grid points
      abscissa_in_PML = yoriginbottom - yval
      if(abscissa_in_PML >= ZERO) then
        abscissa_normalized = abscissa_in_PML / thickness_PML_y
        d_y(j) = d0_y * abscissa_normalized**NPOWER
! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2
        K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER
        alpha_prime_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)
      endif

! define damping profile at half the grid points
      abscissa_in_PML = yoriginbottom - (yval + DELTAY/2.d0)
      if(abscissa_in_PML >= ZERO) then
        abscissa_normalized = abscissa_in_PML / thickness_PML_y
        d_y_half(j) = d0_y * abscissa_normalized**NPOWER
! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2
        K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER
        alpha_prime_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)
      endif

    endif

!---------- top edge
    if(USE_PML_YMAX) then

! define damping profile at the grid points
      abscissa_in_PML = yval - yorigintop
      if(abscissa_in_PML >= ZERO) then
        abscissa_normalized = abscissa_in_PML / thickness_PML_y
        d_y(j) = d0_y * abscissa_normalized**NPOWER
! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2
        K_y(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER
        alpha_prime_y(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)
      endif

! define damping profile at half the grid points
      abscissa_in_PML = yval + DELTAY/2.d0 - yorigintop
      if(abscissa_in_PML >= ZERO) then
        abscissa_normalized = abscissa_in_PML / thickness_PML_y
        d_y_half(j) = d0_y * abscissa_normalized**NPOWER
! from Stephen Gedney's unpublished class notes for class EE699, lecture 8, slide 8-2
        K_y_half(j) = 1.d0 + (K_MAX_PML - 1.d0) * abscissa_normalized**NPOWER
        alpha_prime_y_half(j) = ALPHA_MAX_PML * (1.d0 - abscissa_normalized)
      endif

    endif

    b_y(j) = exp(- (d_y(j) / K_y(j) + alpha_prime_y(j)) * DELTAT)
    b_y_half(j) = exp(- (d_y_half(j) / K_y_half(j) + alpha_prime_y_half(j)) * DELTAT)

! this to avoid division by zero outside the PML
    if(abs(d_y(j)) > 1.d-6) a_y(j) = d_y(j) * (b_y(j) - 1.d0) / (K_y(j) * (d_y(j) + K_y(j) * alpha_prime_y(j)))
    if(abs(d_y_half(j)) > 1.d-6) a_y_half(j) = d_y_half(j) * &
      (b_y_half(j) - 1.d0) / (K_y_half(j) * (d_y_half(j) + K_y_half(j) * alpha_prime_y_half(j)))

  enddo

! beginning of the time loop
  do it = 1,NSTEP

! calculer les premieres derivees spatiales multipliees par les coefficients de Lame
! calculate the first spatial derivatives multiplied by the Lame coefficients
    do j = 1,NY
      do i = 1,NX-1
      value_dpressure_dx = (pressurepresent(i+1,j) - pressurepresent(i,j)) / DELTAX

      memory_dpressure_dx(i,j) = b_x_half(i) * memory_dpressure_dx(i,j) + a_x_half(i) * value_dpressure_dx

      value_dpressure_dx = value_dpressure_dx / K_x_half(i) + memory_dpressure_dx(i,j)

      pressure_xx(i,j) = value_dpressure_dx / rho(i,j)
      enddo
    enddo

    do j = 1,NY-1
      do i = 1,NX
      value_dpressure_dy = (pressurepresent(i,j+1) - pressurepresent(i,j)) / DELTAY

      memory_dpressure_dy(i,j) = b_y_half(j) * memory_dpressure_dy(i,j) + a_y_half(j) * value_dpressure_dy

      value_dpressure_dy = value_dpressure_dy / K_y_half(j) + memory_dpressure_dy(i,j)

      pressure_yy(i,j) = value_dpressure_dy / rho(i,j)
      enddo
    enddo

! calculer les deuxiemes derivees spatiales
! calculate the second spatial derivatives

! pour la mise a jour de pressure ci-dessous   for the update of pressure below
    do j = 1,NY
      do i = 2,NX
      value_dpressurexx_dx = (pressure_xx(i,j) - pressure_xx(i-1,j)) / DELTAX

      memory_dpressurexx_dx(i,j) = b_x(i) * memory_dpressurexx_dx(i,j) + a_x(i) * value_dpressurexx_dx

      value_dpressurexx_dx = value_dpressurexx_dx / K_x(i) + memory_dpressurexx_dx(i,j)

      dpressurexx_dx(i,j) = value_dpressurexx_dx
      enddo
    enddo

! pour la mise a jour ci-dessous      for the update below
    do j = 2,NY
      do i = 1,NX
      value_dpressureyy_dy = (pressure_yy(i,j) - pressure_yy(i,j-1)) / DELTAY

      memory_dpressureyy_dy(i,j) = b_y(j) * memory_dpressureyy_dy(i,j) + a_y(j) * value_dpressureyy_dy

      value_dpressureyy_dy = value_dpressureyy_dy / K_y(j) + memory_dpressureyy_dy(i,j)

      dpressureyy_dy(i,j) = value_dpressureyy_dy
      enddo
    enddo

! appliquer le schema d'evolution en temps
! on l'applique partout y compris sur certains points du bord qui n'ont pas ete calcules
! ci-dessus, ce qui est faux, mais ce n'est pas grave car on efface ces fausses valeurs
! juste apres en appliquant les conditions de Dirichlet ci-dessous

! apply the evolution scheme in time
! it is applied everywhere including on certain points of the edge which have not been calculated
! above, which is wrong, but it does not matter because we erase these false values
! just after applying the Dirichlet conditions below

  pressurefuture(:,:) = - pressurepast(:,:) + 2.d0 * pressurepresent(:,:) + &
                                  DELTAT*DELTAT * (dpressurexx_dx(:,:) + dpressureyy_dy(:,:)) * kappa(:,:)

! imposer les conditions de bord rigide de Dirichlet (pression nulle)
! impose rigid Dirichlet edge conditions (zero pressure)
! this applies Dirichlet at the bottom of the C-PML layers,
! which is the right condition to implement in order for C-PML to remain stable at long times

! bord de gauche
  pressurefuture(1,:) = ZERO

! bord de droite
  pressurefuture(NX,:) = ZERO

! bord du bas
  pressurefuture(:,1) = ZERO

! bord du haut
  pressurefuture(:,NY) = ZERO

! ajouter la source (Ricker) au point de la grille ou est situee la pression source
! add the source (Ricker) to the grid point where the source pressure is located

do i = 1, NSOURCES
  if (sourcefilecheck) then! override calculations above
    i_source = i_sources(i)
    j_source = j_sources(i)
  end if
    a = pi*pi*f0*f0
    t = dble(it-1)*DELTAT
    force_x = factor * (1.d0-2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2)
    force_y = factor * (1.d0-2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2)
    pressurefuture(i_source,j_source) = pressurefuture(i_source,j_source) + force_x / rho(i_source,j_source)
end do

! store seismograms
  do irec = 1,NREC
    sispressure(it,irec) = pressurepresent(ix_rec(irec),iy_rec(irec))! ie pressure field sampled at rec locations
  enddo

! ALWAYS write wavefield to binary (!)
  if (OUTPUT_WAVEFIELD == 1) then
    call write_wavefield(pressurepresent,NX,NY,it,OUT_DIR,SIM_NUM)
  end if

! output information every IT_AFFICHE time steps, and at time it=5
  if(mod(it,IT_AFFICHE) == 0 .or. it == 5) then

! print max absolute value of pressure
    pressure_max_all = maxval(abs(pressurepresent))
    !print *,'time step it, time t = ',it,dble(it-1)*DELTAT
    !print *,'max absolute value of pressure is ',pressure_max_all

! check stability of the code, exit if unstable
    if(pressure_max_all > STABILITY_THRESHOLD) then
        print *,'code became unstable and blew up'
        stop 1
    endif

! display de la pression sous forme d'image en couleur
    !call create_color_image(pressurepresent,NX,NY,it)  ! ie full pressure field  (it is iteration number)
    !print *,'image file written'
    !print *

  endif

! move new values to old values (the present becomes the past, the future becomes the present)
  pressurepast(:,:) = pressurepresent(:,:)
  pressurepresent(:,:) = pressurefuture(:,:)

  enddo   ! end of the time loop

! Always save seismograms
  call write_seismograms(sispressure,NSTEP,NREC,OUT_DIR,SIM_NUM)

! deallocate dynamic arrays

deallocate(ix_rec)
deallocate(iy_rec)

deallocate(i_sources)
deallocate(j_sources)

deallocate(sispressure)

deallocate(xgrid)
deallocate(ygrid)
deallocate(pressurepast)
deallocate(pressurepresent)
deallocate(pressurefuture)
deallocate(pressure_xx)
deallocate(pressure_yy)
deallocate(dpressurexx_dx)
deallocate(dpressureyy_dy)
deallocate(kappa)
deallocate(cp)
deallocate(rho)

deallocate(memory_dpressure_dx)
deallocate(memory_dpressure_dy)
deallocate(memory_dpressurexx_dx)
deallocate(memory_dpressureyy_dy)

deallocate(d_x)
deallocate(K_x)
deallocate(alpha_prime_x)
deallocate(a_x)
deallocate(b_x)
deallocate(d_x_half)
deallocate(K_x_half)
deallocate(alpha_prime_x_half)
deallocate(a_x_half)
deallocate(b_x_half)

deallocate(d_y)
deallocate(K_y)
deallocate(alpha_prime_y)
deallocate(a_y)
deallocate(b_y)
deallocate(d_y_half)
deallocate(K_y_half)
deallocate(alpha_prime_y_half)
deallocate(a_y_half)
deallocate(b_y_half)

end program seismic_CPML_2D_pressure

!----
!----  routine de sauvegarde des sismogrammes
!----  backup routine of seismograms

subroutine write_wavefield(pressurepresent,NX,NY,it,OUT_DIR,SIM_NUM)

! save the full wavefield in ASCII format

implicit none

integer :: NX,NY,it
double precision, dimension(NX,NY) :: pressurepresent

integer :: ix,iy

character(len=*) :: OUT_DIR
character(len=512) :: file_name
integer :: record_len

integer :: SIM_NUM

!! WRITE AS A 64-bit BINARY file (for accuracy,speed,file size)

write(file_name,"('wavefield_',i8.8,'_',i8.8,'.bin')") SIM_NUM, it
file_name = trim(OUT_DIR)//trim(file_name)

! get record length (should be 8 bytes * NX for double precision)
inquire(iolength=record_len) pressurepresent(:,1)

! first delete the file (in case it is larger)
open(50, file=file_name, form='unformatted', access = 'direct', recl = record_len)
close(50, status='delete')
open(51, file=file_name, form='unformatted', access = 'direct', recl = record_len)
! write values
do iy=1,NY
  write(51, rec=iy) pressurepresent(:,iy)
  !write(51,"(i4.4,1x,i4.4,1x,f9.4)") ix,iy,pressurepresent(:,iy)! for text file output
enddo
close(51)

end subroutine write_wavefield

subroutine write_seismograms(sispressure,NSTEP,NREC,OUT_DIR,SIM_NUM)

! save the full wavefield in ASCII format

implicit none

integer :: NSTEP,NREC
double precision, dimension(NSTEP,NREC) :: sispressure

integer :: it,irec

character(len=*) :: OUT_DIR
character(len=512) :: file_name
integer :: record_len

integer :: SIM_NUM

!! WRITE AS A 64-bit BINARY file (for accuracy,speed,file size)

write(file_name,"('gather_',i8.8,'.bin')") SIM_NUM
file_name = trim(OUT_DIR)//trim(file_name)

! get record length (should be 8 bytes * NX for double precision)
inquire(iolength=record_len) sispressure(:,1)

! first delete the file (in case it is larger)
open(52, file=file_name, form='unformatted', access = 'direct', recl = record_len)
close(52, status='delete')
open(53, file=file_name, form='unformatted', access = 'direct', recl = record_len)
! write values
do irec=1,NREC
  write(53, rec=irec) sispressure(:,irec)
  !write(53,"(i4.4,1x,i4.4,1x,f9.4)") ix,iy,pressurepresent(:,iy)! for text file output
enddo
close(53)

end subroutine write_seismograms


      MODULE m_spgrot
!     **********************************************************
!     perform space group operations of film
!     **********************************************************
      CONTAINS
      SUBROUTINE spgrot(
     >                  nop,symor,mrot,tau,invtab,
     >                  k,
     <                  kr,phas)
      USE m_constants
      IMPLICIT NONE
!     ..
!     .. Scalar Arguments ..
      INTEGER, INTENT (IN)  :: nop
      LOGICAL, INTENT (IN)  :: symor
!     ..
!     .. Array Arguments ..
      INTEGER, INTENT (IN)  :: k(3),mrot(3,3,nop),invtab(nop)
      REAL,    INTENT (IN)  :: tau(3,nop)
      INTEGER, INTENT (OUT) :: kr(3,nop)
      COMPLEX,OPTIONAL, INTENT (OUT) :: phas(nop)
!     ..
!     .. Local Scalars ..
      INTEGER n,ni

      DO n = 1,nop
         kr(:,n) = matmul(k,mrot(:,:,n))
      ENDDO
      if (.not. present(phas)) RETURN
      IF (symor) THEN
            phas(:) = 1.
      ELSE
         DO n = 1,nop
            ni = invtab(n)
            phas(n) = exp(cmplx(0.0,-1.0)*tpi_const*
     +                   dot_product(real(kr(:,n)),tau(:,ni)))
! note that, in general phas(n) could be complex!
         ENDDO
      END IF
      RETURN
      END SUBROUTINE spgrot
      END MODULE m_spgrot