PROGRAM test_output
IMPLICIT NONE
INTEGER, DIMENSION(0:7) :: my_data
INTEGER :: i, j
my_data = (/  1,  2,  3,  4, 5, 6, 7, 8 /)

DO i = 0,1
   WRITE (*,100) (my_data(4*i+j), j=0,3)
   100 FORMAT (6(1X,I4))
END DO
WRITE (*,100) ((my_data(4*i+j), j=0,3), i=0,1)
END PROGRAM test_output


program addNumbers
    ! This simple program add 2 numbers
    implicit none
    ! Type Declarations
    real :: a,b,result
    complex::cd
    !Executable statements
    a=12.0
    b=15.0
    result=a+b
    print *, "The total is: ",result
end program


module pm_commons
  use amr_parameters
  use pm_parameters
  use random
  ! Sink particle related arrays
  real(dp),allocatable,dimension(:)::msink,r2sink,v2sink,c2sink,oksink_new,oksink_all
  real(dp),allocatable,dimension(:)::tsink,tsink_new,tsink_all
  real(dp),allocatable,dimension(:)::msink_new,msink_all,r2k,v2sink_new,c2sink_new
  real(dp),allocatable,dimension(:)::v2sink_all,c2sink_all
  real(dp),allocatable,dimension(:)::xmsink
  real(dp),allocatable,dimension(:)::dMsink_overdt
  real(dp),allocatable,dimension(:)::delta_mass,delta_mass_new,delta_mass_all
  real(dp),allocatable,dimension(:)::vol_gas_agn,mass_gas_agn
  real(dp),allocatable,dimension(:)::mass_blast_agn,vol_blast_agn,p_agn
  real(dp),allocatable,dimension(:)::vol_gas_agn_all,mass_gas_agn_all
  real(dp),allocatable,dimension(:)::wden,weth,wvol,wden_new,weth_new,wvol_new
  real(dp),allocatable,dimension(:,:)::divsink,divsink_new
  real(dp),allocatable,dimension(:)::total_volume
  real(dp),allocatable,dimension(:,:)::wmom,wmom_new
  real(dp),allocatable,dimension(:,:)::vsink,vsink_new,vsink_all
  real(dp),allocatable,dimension(:,:)::fsink,fsink_new,fsink_all
  real(dp),allocatable,dimension(:,:,:)::vsnew,vsold
  real(dp),allocatable,dimension(:,:,:)::fsink_partial,sink_jump
  real(dp),allocatable,dimension(:,:)::lsink,lsink_new,lsink_all !sink angular momentum
  real(dp),allocatable,dimension(:,:)::xsink,xsink_new,xsink_all
  real(dp),allocatable,dimension(:)::acc_rate,acc_lum !sink accretion rate and luminosity
  real(dp),allocatable,dimension(:,:)::weighted_density,weighted_volume,weighted_ethermal
  real(dp),allocatable,dimension(:,:,:)::weighted_momentum
  integer,allocatable,dimension(:)::idsink,idsink_new,idsink_old,idsink_all
  integer,allocatable,dimension(:)::level_sink,level_sink_new,level_sink_all
  logical,allocatable,dimension(:)::ok_blast_agn,ok_blast_agn_all
  integer,allocatable,dimension(:)::idsink_sort,ind_blast_agn,new_born,new_born_all
  integer::ncloud_sink
  integer::nindsink=0

  ! Particles related arrays
  real(dp),allocatable,dimension(:,:)::xp       ! Positions
  real(dp),allocatable,dimension(:,:)::vp       ! Velocities
  real(dp),allocatable,dimension(:)  ::mp       ! Masses
#ifdef OUTPUT_PARTICLE_POTENTIAL
  real(dp),allocatable,dimension(:)  ::ptcl_phi ! Potential of particle added by AP for output purposes
#endif
  real(dp),allocatable,dimension(:)  ::tp       ! Birth epoch
  real(dp),allocatable,dimension(:)  ::zp       ! Birth metallicity
  integer ,allocatable,dimension(:)  ::nextp    ! Next particle in list
  integer ,allocatable,dimension(:)  ::prevp    ! Previous particle in list
  integer ,allocatable,dimension(:)  ::levelp   ! Current level of particle
  integer ,allocatable,dimension(:)  ::idp      ! Identity of particle
  ! Tree related arrays
  integer ,allocatable,dimension(:)  ::headp    ! Head particle in grid
  integer ,allocatable,dimension(:)  ::tailp    ! Tail particle in grid
  integer ,allocatable,dimension(:)  ::numbp    ! Number of particles in grid
  ! Global particle linked lists
  integer::headp_free,tailp_free,numbp_free=0,numbp_free_tot=0
  ! Local and current seed for random number generator
  integer,dimension(IRandNumSize) :: localseed=-1
end module pm_commons


! Demonstrate if-elseif-endif
program if_elseif
implicit none
integer :: i
do i=-1,1
   print*,i
   if (i < 0) then
      print*,"negative"
   else if (i == 0) then
      print*,"zero"
   else
      print*,"positive"
   end if
   print*
end do
end program if_elseif


      SUBROUTINE INSTAR
*
*
*       Initialization of stars.
*       ------------------------
*
      INCLUDE 'common6.h'
      REAL*8 TSCLS(20),LUMS(10),GB(10),TM,TN
      REAL*8 M0,M1,RM,LUM,AGE,MC,RCC
      REAL*8 MENV,RENV,K2,K3
      PARAMETER(K3=0.21D0)
      REAL*8 JSPIN,OSPIN
      REAL*8 VROTF
      EXTERNAL VROTF
*
*
*       Initialize mass loss variables & counters.
      TPHYS = 0.d0
      ZMRG = 0.d0
      ZMHE = 0.d0
      ZMRS = 0.d0
      ZMWD = 0.d0
      ZMSN = 0.d0
      ZMDOT = 0.d0
      NMDOT = 0
      NRG = 0
      NHE = 0
      NRS = 0
      NWD = 0
      NSN = 0
      NBH = 0
      NTZ = 0
      NBS = 0
      NKICK = 0
      NBKICK = 0
*
*NB4 NEW
      ZMNH = 0.d0
      ZMBH = 0.d0
      ZMSY = 0.d0
      NROCHE = 0
      NCHAOS = 0
      IQCOLL = 0
      IBLUE = 0
      NCHA = 0
      NSP = 0
      NHG = 0
      NNH = 0
      NBR = 0
      NAS = 0
      NRO = 0
      NDD = 0
      NSPIR = 0
      NCIRC = 0
      NSLP = 0
      NCONT = 0
      NCOAL = 0
      NCE = 0
      INSTAB = 0
      NEINT = 0
      NEMOD = 0
      NHYP = 0
      NHYPC = 0.0
      NGB = 0
      NMS = N
*
      TMDOT = 1.0d+10
*NB6  IF (KZ(27).EQ.0) THEN
*         TSTAR = TSCALE
*     END IF
*
      WRITE (6,9)  ZPARS(11), ZPARS(12), ZMET
 9    FORMAT(//,12X,'ABUNDANCES: X =',F6.3,' Y =',F6.3,' Z =',F6.3)
*NB6  zpars(11)=xhyd
*     zpars(12)=yhel
*
*       Calculate scale factor for spin angular momentum.
      SPNFAC = ZMBAR*SU**2/(1.0D+06*TSTAR)
*
      EPOCH1 = EPOCH0
      DO 10 I = 1,N
*
*       Obtain stellar parameters at current epoch.
          IF(KZ(12).EQ.2)THEN
             READ(12,*)M1,KW,M0,EPOCH1,OSPIN
          ELSE
             M1 = BODY(I)*ZMBAR
             M0 = M1
             IF(KSTAR(I).GT.1)THEN
                KW = KSTAR(I)
             ELSE
*       Include optional pre-mainsequence evolution.
                IF (M1.LT.8.0.AND.KZ(41).GT.0) THEN
                    KW = -1
                ELSE
                    KW = 1
                END IF
*               IF(M0.LE.0.01D0) KW = 10
*               IF(M0.GE.100.D0) KW = 14
                IF (KZ(45).GT.0.AND.M0.GT.10.0.AND.I.LE.KZ(24)) KW = 14
             ENDIF
          ENDIF
          MC = 0.D0
          AGE = TIME*TSTAR - EPOCH1
          CALL star(KW,M0,M1,TM,TN,TSCLS,LUMS,GB,ZPARS)
*       Define preMS EPOCH & AGE if relevant.
          IF (KW.EQ.-1) THEN
              EPOCH(I) = TSCLS(15)
              AGE = TIME*TSTAR - EPOCH(I)
          END IF
          CALL hrdiag(M0,AGE,M1,TM,TN,TSCLS,LUMS,GB,ZPARS,
     &                RM,LUM,KW,MC,RCC,MENV,RENV,K2)
*
*       Assign initial spin angular momentum.
          IF(KZ(22).EQ.3)THEN
             JSPIN = (K2*(M1-MC)*RM**2 + K3*MC*RCC**2)*OSPIN
          ELSE
             OSPIN = 45.35d0*VROTF(M1)/RM
             JSPIN = K2*M1*RM**2*OSPIN
             IF(KW.GT.1) JSPIN = 0.D0
          ENDIF
*
*       Convert from solar radii to scaled units (assume Sun = 1/215 AU).
          IF (KZ(27).EQ.-2) THEN
              RADIUS(I) = 0.d0
              ZLMSTY(I) = 0.d0
              SPIN(I) = 0.d0
          ELSE
              RADIUS(I) = RM/SU
              ZLMSTY(I) = LUM
              SPIN(I) = JSPIN/SPNFAC
          END IF
*
*       Check neutron star option for GR capture (avoid large masses).
          IF (KZ(27).EQ.3.AND.KZ(28).EQ.4) THEN
              RADIUS(I) = 1.0D-12/(3.0*RBAR)
              KW = 13
              TEV(I) = 1000.0
              M0 = 25.0
              EPOCH(I) = -15.0/TSTAR
              IF (I.EQ.1) WRITE (6,5)  M1, KW, RADIUS(I)*SU
    5         FORMAT (/,12X,'FIRST STAR:    M K* R/SU ',F7.2,I4,1P,E9.1)
          END IF
*
*       Initialize the stellar classification type (KW = 0 - 15).
          KSTAR(I) = KW
*
*       Save the initial mass of all the stars in sequential order.
          BODY(I) = M1/ZMBAR
          BODY0(I) = M0/ZMBAR
*
*       Set initial look-up time.
          EPOCH(I) = TIME*TSTAR - AGE
          TEV0(I) = TIME
          CALL TRDOT(I,DTM,M1)
          TEV(I) = DTM
          IF (KW.GE.13) TEV(I) = 0.0
*
*       Determine the time for next stellar evolution check.
          IF (TEV(I).LT.TMDOT) THEN
              TMDOT = TEV(I)
          END IF
          IF (I.EQ.1.AND.KZ(41).GT.0) THEN
              WRITE (6,8)  M1, TEV(I), RADIUS(I)*SU
    8         FORMAT (/,12X,'BEGIN STAR #1    M TEV r*  ',
     &                       F7.2,1P,2E10.2)
          END IF
*
   10 CONTINUE
*
*       Define first quantized step < 1000 yrs (minimum interval for MDOT).
*       (changed to 100 yr to be consistent with trdot: 2/8/02)
      DT = 1.0d-04/TSCALE
      CALL STEPK(DT,DTN)
      IF(DTN*TSCALE.LT.100.0) DTN = 2.d0*DTN
      STEPX = DTN
*
*        Ensure binary components will be updated at the same time.
      DO 15 I = 1,NBIN0
         I1 = 2*I - 1
         I2 = I1 + 1
         TEV(I1) = MIN(TEV(I1),TEV(I2))
         TEV(I1) = MIN(TEV(I1),10.D0*STEPX)
         TMDOT = MIN(TMDOT,TEV(I1))
         TEV(I2) = TEV(I1)
   15 CONTINUE
*
*       Initialize stellar collision matrix.
*
      ktype(0,0) = 1
      do 20 j = 1,6
         ktype(0,j) = j
         ktype(1,j) = j
 20   continue
      ktype(0,7) = 4
      ktype(1,7) = 4
      do 25 j = 8,12
         if(j.ne.10)then
            ktype(0,j) = 6
         else
            ktype(0,j) = 3
         endif
         ktype(1,j) = ktype(0,j)
 25   continue
      ktype(2,2) = 3
      do 30 i = 3,14
         ktype(i,i) = i
 30   continue
      ktype(5,5) = 4
      ktype(7,7) = 1
      ktype(10,10) = 15
*       Change for CO+CO owing to Tout theory (21/11/08).
      ktype(11,11) = 12
      ktype(13,13) = 14
      do 35 i = 2,5
         do 40 j = i+1,12
            ktype(i,j) = 4
 40      continue
 35   continue
      ktype(2,3) = 3
      ktype(2,6) = 5
      ktype(2,10) = 3
      ktype(2,11) = 5
      ktype(2,12) = 5
      ktype(3,6) = 5
      ktype(3,10) = 3
      ktype(3,11) = 5
      ktype(3,12) = 5
      ktype(6,7) = 4
      ktype(6,8) = 6
      ktype(6,9) = 6
      ktype(6,10) = 5
      ktype(6,11) = 6
      ktype(6,12) = 6
      ktype(7,8) = 8
      ktype(7,9) = 9
      ktype(7,10) = 7
      ktype(7,11) = 9
      ktype(7,12) = 9
      ktype(8,9) = 9
      ktype(8,10) = 7
      ktype(8,11) = 9
      ktype(8,12) = 9
      ktype(9,10) = 7
      ktype(9,11) = 9
      ktype(9,12) = 9
      ktype(10,11) = 9
      ktype(10,12) = 9
      ktype(11,12) = 12
      do 45 i = 0,12
         ktype(i,13) = 13
         ktype(i,14) = 14
 45   continue
      ktype(13,14) = 14
*
*       Increase common-envelope cases by 100.
      do 50 i = 0,9
         do 55 j = i,14
            if(i.le.1.or.i.eq.7)then
               if(j.ge.2.and.j.le.9.and.j.ne.7)then
                  ktype(i,j) = ktype(i,j) + 100
               endif
            else
               ktype(i,j) = ktype(i,j) + 100
            endif
 55      continue
 50   continue
*
*       Assign the remaining values by symmetry.
      do 60 i = 1,14
         do 65 j = 0,i-1
            ktype(i,j) = ktype(j,i)
 65      continue
 60   continue
*
      WRITE (6,75)  KTYPE
   75 FORMAT (/,11X,' KTYPE: ',15I4,14(/,19X,15I4))
*
      RETURN
      END


      subroutine subsidence(iflg)
!***********************************************************************
! Copyright 2011. Los Alamos National Security, LLC.  This material was
! produced under U.S. Government contract DE-AC52-06NA25396 for Los
! Alamos National Laboratory (LANL), which is operated by Los Alamos
! National Security, LLC for the U.S. Department of Energy. The U.S.
! Government has rights to use, reproduce, and distribute this software.
! Neither the U.S. Government nor Los Alamos National Security, LLC or
! persons acting on their behalf, make any warranty, express or implied,
! or assumes any liability for the accuracy, completeness, or usefulness
! of the software, any information pertaining to the software, or
! represents that its use would not infringe privately owned rights.
!
! The software being licensed may be Export Controlled.   It may not be
! distributed or used by individuals or entities prohibited from having
! access to the software package, pursuant to United States export
! control laws and regulations.  An export control review and
! determination must be completed before LANS will provide access to the
! identified Software.
!***********************************************************************

c
c apply freeze-thaw to porosity change  and gridblock thickness
c
      use comai
      use combi
      use comci, only : dil,dile,deqh,dqh,dqt,dq,enlf,delf,delef
      use comdi
      use comsi
      implicit none
      real*8 z_i,z_kb,delzi,delzkb,z_tol,dz_max,coeff_ps
      real*8 delx2,dely2,delz2,ratio,tl,cos_z2,dz_temp
      real*8 PorosCoeff,DeltaHeight,z_plot_i,DeltaPres,KozenyCoeff
      real*8 AvgPoros,Counter,SubsWaveLength,SubsTime
      real*8 KinViscInv,KinViscInv0,DKVIT,skold,qhold,permsd
      integer iflg,i,i1,i2,j,kb,jj,kk,kb_max,ToDrain
      integer open_file,UnitNum
      parameter (z_tol=1.d-30,KinViscInv0 = 1.d6)
      if(i_subsid.eq.0) return
      if(iflg.eq.0) then
c read input,perform initial calculations (identify bottom/top zones)
       allocate(izone_bot(neq))
       allocate(izone_top(neq))
       allocate(izone_drain(neq))
       allocate(izone_main(neq))
       izone_bot = 0
       izone_top = 0
       izone_drain = 0
       izone_main = 0
       allocate(i_chk(neq))
       allocate(z_plot(neq))
       allocate(z_plot_old(neq))
       allocate(dzrg_sub(neq))
       z_plot_old = 0.0
       ! read in fixed (usually bottom) boundary zone(s)
       read(inpt,*) kk, (i_chk(i), i = 1,kk)
       do jj = 1, kk
        i1 = i_chk(jj)
        do i = 1,neq
         if(izonef(i).eq.i1) izone_bot(i) = 3
        enddo
       enddo
       ! read in top boundary zone(s)
       read(inpt,*) kk, (i_chk(i), i = 1,kk)
       do jj = 1, kk
        i1 = i_chk(jj)
        do i = 1,neq
         if(izonef(i).eq.i1) then
            izone_top(i) = 3
         end if
        enddo
       enddo
       ! read in drainage face
       read(inpt,*) kk, (i_chk(i), i = 1,kk)
       do jj = 1, kk
        i1 = i_chk(jj)
        do i = 1,neq
         if(izonef(i).eq.i1) then
            izone_drain(i) = 3
         end if
        enddo
       enddo
       ! read in ice-rich zone
       read(inpt,*) kk, (i_chk(i), i = 1,kk)
       do jj = 1, kk
        i1 = i_chk(jj)
        do i = 1,neq
         if(izonef(i).eq.i1) then
            izone_main(i) = 3
         end if
        enddo
       enddo
      else if(iflg.eq.-1) then
c calculate dzrg if not already done
         call airctr(11,0)
         ! KCL allocate pnx0,pny0,pnz0 with neq
         ! set equal to pnx, pny, and pnz
         allocate(pnx0(neq))
         allocate(pny0(neq))
         allocate(pnz0(neq))
         allocate(MaxDrainPart(neq))
         allocate(InitPoros(neq))
         allocate(InitPerm(neq))
         allocate(InitPres(neq))
         DrainInitFlag = 0
      else if(iflg.eq.1) then
c calculate subsidence
       if(itsat.eq.11) then
c first identify frozen and unfrozen soils
        ieos_aux = 0
        do i = 1, neq
         if(t(i).lt.IceEndTemp) then
          ieos_aux(i) = -1
         endif
        enddo
       endif
c
c calculate changes in gridblock height
c
       if ((days>0).and.(DrainInitFlag==0)) then
          DrainInitFlag = 1
          do i = 1, neq
             pnx0(i) = pnx(i)
             pny0(i) = pny(i)
             pnz0(i) = pnz(i)
             psini(i) = ps(i)

c next line is for test only
c             psini(i) = ((0.6-0.3)/1.e5)*(phi(i)-1.e5)+0.3

             MaxDrainPart(i) = 0.0
             InitPoros(i) = psini(i)
             InitPerm(i)  = pnz0(i)
             InitPres(i)  = phini(i)
          end do
       end if

       dzrg_sub = dzrg
       ToDrain = 1
       do i = 1, neq
         tl = t(i)
         coeff_ps  = PorosCoeff(i,tl,phi(i),ToDrain)
         ps(i) = psini(i)*coeff_ps

c for analytic comparision only!
c         ps(i) = 0.6*coeff_ps

         dzrg_sub(i) = dzrg(i) +
     &      DeltaHeight(i,dzrg(i),ps(i))
         pnx(i) = KozenyCoeff(i,ps(i))*pnx0(i)
         pny(i) = KozenyCoeff(i,ps(i))*pny0(i)
         pnz(i) = KozenyCoeff(i,ps(i))*pnz0(i)

c for analytic comparision only!
c         pnx(i) = 1.e-7 + 5.e-7*(phi(i)-0.1D0)
c         pny(i) = pnx(i)
c         pnz(i) = pnx(i)
       enddo

c       dzrg_sub = dzrg
c       dzrg_sub(2460:2466) = 10.
c       dzrg_sub(2512:2561) = 10.
c
c initialize z_plot
c
       do i = 1,neq
        z_plot(i) = cord(i,igrav)
        i_chk(i) = 0
       enddo
       do jj = 1, neq
c start a fixed z displacement
        if(izone_bot(jj).ne.0) then
c
c loop until all nodes are touched
c need to first check for block centered FDM numerics
c for now this assumes
c
         if(ivf.eq.-1) then
          z_plot(jj) =  cord(jj,igrav) - dzrg_sub(jj)/2.
         endif
         i = jj

100      continue
         i1 = nelm(i)+1
         i2 = nelm(i+1)
         z_plot_i = z_plot(i)
         z_i = cord(i,igrav)
         delzi = dzrg(i)
         dz_max = 0.
         kb_max = i
         do j = i1,i2
          kb = nelm(j)
          if(kb.ne.i) then
           delx2=(cord(kb,1)-cord(i,1))**2
	       dely2=(cord(kb,2)-cord(i,2))**2
	       if(icnl.eq.0) dely2 = dely2 + (cord(kb,3)-cord(i,3))**2
           z_kb = cord(kb,igrav)-z_tol
           cos_z2 = (z_kb-z_i)**2/(delx2+dely2)
           dz_temp = (z_kb-z_i)*cos_z2
           if(dz_temp.gt.dz_max) then
            dz_max = dz_temp
            kb_max = kb
           endif
          endif
         enddo
         if(kb_max.ne.i) then
c
c  calculate a new z coordinate
c
          ratio = (dzrg_sub(i)+dzrg_sub(kb_max))/(dzrg(i)+dzrg(kb_max))
          z_plot(kb_max) = z_plot_i + dz_max*ratio
          i = kb_max
          go to 100
         else
          go to 101
         endif
        endif
101    continue
       enddo
c check for completeness
       do i = 1, neq
        if(izone_bot(i).ne.0) then
        endif
       enddo
c KCL inserted to convert from coords to displacements
       do i = 1, neq
          z_plot(i) = z_plot(i) - cord(i,igrav)
       end do
      elseif (iflg.eq.2) then
         UnitNum = open_file('Predict.out','unknown')

         ! calculate and write average porosity in icy layer
         Counter = 0.0
         AvgPoros = 0.0
         do i = 1,neq
            if ((izone_main(i)==3).or.(izone_top(i)==3)) then
               AvgPoros = AvgPoros + ps(i)
               Counter = Counter + 1.0
            end if
         end do
         AvgPoros = AvgPoros/Counter
         write(UnitNum,*) 'avg porosity: ',AvgPoros
         write(*,*) 'avg porosity: ',AvgPoros

         ! calculate and write subsidence wavelength
         call GetSubsWaveLength(SubsWaveLength)
         write(UnitNum,*) 'subsidence wavelength: ',SubsWaveLength
         write(*,*) 'subsidence wavelength: ', SubsWaveLength

         close(UnitNum)
      else if(iflg.eq.3) then
c
c modify source/sink term for ice
c
c        return
        i = iad
        if(l.eq.0) return
        do i = 1, neq
          if(izone_drain(i).ne.0) then
            KinViscInv =  dil(i)

c            ratio = KinViscInv/KinViscInv0
            DKVIT = dile(i)/KinViscInv0
            if(t(i).lt.IceEndTemp) then
             ratio = 0.0
             DKVIT = 0.0
            else if(t(i).gt.LiqEndTemp) then
             ratio = 1.0
             DKVIT = 0.0
            else
             ratio = ((t(i)-IceEndTemp)/(LiqEndTemp-IceEndTemp))**2
             DKVIT = 2.0*((t(i)-IceEndTemp)/(LiqEndTemp-IceEndTemp))/
     &        (LiqEndTemp-IceEndTemp)
            endif
            permsd=abs(wellim(i))
            sk(i) = permsd*ratio*(phi(i)-pflow(i))
            dq(i) = permsd*ratio
            dqt(i) = permsd*DKVIT*(phi(i)-pflow(i))
            if(sk(i).ge.0.0) then
             qh(i) = sk(i)*enlf(i)
             dqh(i) = dq(i)*enlf(i)+sk(i)*delf(i)
             deqh(i) = dqt(i)*enlf(i) + sk(i)*delef(i)
            else
             qh(i) = sk(i)*eflow(i)
             dqh(i) = dq(i)*eflow(i)
             deqh(i) = dqt(i)*eflow(i)
            endif
          endif
        enddo

      end if

      end


C$Procedure ZZSTELAB ( Private --- stellar aberration correction )

      SUBROUTINE ZZSTELAB ( XMIT, ACCOBS, VOBS, STARG, SCORR, DSCORR )

C$ Abstract
C
C     SPICE Private routine intended solely for the support of SPICE
C     routines.  Users should not call this routine directly due
C     to the volatile nature of this routine.
C
C     Return the state (position and velocity) of a target body
C     relative to an observing body, optionally corrected for light
C     time (planetary aberration) and stellar aberration.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     SPK
C
C$ Keywords
C
C     EPHEMERIS
C
C$ Declarations

      IMPLICIT NONE

      LOGICAL               XMIT
      DOUBLE PRECISION      ACCOBS ( 3 )
      DOUBLE PRECISION      VOBS   ( 3 )
      DOUBLE PRECISION      STARG  ( 6 )
      DOUBLE PRECISION      SCORR  ( 3 )
      DOUBLE PRECISION      DSCORR ( 3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     XMIT       I   Reception/transmission flag.
C     ACCOBS     I   Observer acceleration relative to SSB.
C     VOBS       I   Observer velocity relative to to SSB.
C     STARG      I   State of target relative to observer.
C     SCORR      O   Stellar aberration correction for position.
C     DSCORR     O   Stellar aberration correction for velocity.
C
C$ Detailed_Input
C
C     XMIT        is a logical flag which is set to .TRUE. for the
C                 "transmission" case in which photons *depart* from
C                 the observer's location at an observation epoch ET
C                 and arrive at the target's location at the light-time
C                 corrected epoch ET+LT, where LT is the one-way light
C                 time between observer and target; XMIT is set to
C                 .FALSE. for "reception" case in which photons depart
C                 from the target's location at the light-time
C                 corrected epoch ET-LT and *arrive* at the observer's
C                 location at ET.
C
C                 Note that the observation epoch is not used in this
C                 routine.
C
C                 XMIT must be consistent with any light time
C                 corrections used for the input state STARG: if that
C                 state has been corrected for "reception" light time;
C                 XMIT must be .FALSE.; otherwise XMIT must be .TRUE.
C
C     ACCOBS      is the geometric acceleration of the observer
C                 relative to the solar system barycenter. Units are
C                 km/sec**2. ACCOBS must be expressed relative to
C                 an inertial reference frame.
C
C     VOBS        is the geometric velocity of the observer relative to
C                 the solar system barycenter. VOBS must be expressed
C                 relative to the same inertial reference frame as
C                 ACCOBS. Units are km/sec.
C
C     STARG       is the Cartesian state of the target relative to the
C                 observer. Normally STARG has been corrected for
C                 one-way light time, but this is not required. STARG
C                 must be expressed relative to the same inertial
C                 reference frame as ACCOBS. Components are
C                 (x, y, z, dx, dy, dz). Units are km and km/sec.
C
C$ Detailed_Output
C
C     SCORR       is the stellar aberration correction for the position
C                 component of STARG. Adding SCORR to this position
C                 vector produces the input observer-target position,
C                 corrected for stellar aberration.
C
C                 The reference frame of SCORR is the common frame
C                 relative to which the inputs ACCOBS, VOBS, and STARG
C                 are expressed. Units are km.
C
C     DSCORR      is the stellar aberration correction for the velocity
C                 component of STARG. Adding DSCORR to this velocity
C                 vector produces the input observer-target velocity,
C                 corrected for stellar aberration.
C
C                 The reference frame of DSCORR is the common frame
C                 relative to which the inputs ACCOBS, VOBS, and STARG
C                 are expressed. Units are km/s.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) If attempt to divide by zero occurs, the error
C        SPICE(DIVIDEBYZERO) will be signaled. This case may occur
C        due to uninitialized inputs.
C
C     2) Loss of precision will occur for geometric cases in which
C        VOBS is nearly parallel to the position component of STARG.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine computes a Newtonian estimate of the stellar
C     aberration correction of an input state. Normally the input state
C     has already been corrected for one-way light time.
C
C     Since stellar aberration corrections are typically "small"
C     relative to the magnitude of the input observer-target position
C     and velocity, this routine avoids loss of precision by returning
C     the corrections themselves rather than the corrected state
C     vector. This allows the caller to manipulate (for example,
C     interpolate) the corrections with greater accuracy.
C
C$ Examples
C
C     See SPICELIB routine SPKACS.
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     SPK Required Reading.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C
C$ Version
C
C-    SPICELIB Version 2.0.0, 15-APR-2014 (NJB)
C
C        Added RETURN test and discovery check-in.
C        Check for division by zero was added. This
C        case might occur due to uninitialized inputs.
C
C-    SPICELIB Version 1.0.1, 12-FEB-2009 (NJB)
C
C        Minor updates were made to the inline documentation.
C
C-    SPICELIB Version 1.0.0, 17-JAN-2008 (NJB)
C
C-&

C
C     Note for the maintenance programmer
C     ===================================
C
C     The source code of the test utility T_ZZSTLABN must be
C     kept in sync with the source code of this routine. That
C     routine uses a value of SEPLIM that forces the numeric
C     branch of the velocity computation to be taken in all
C     cases. See the documentation of that routine for details.
C

C
C     SPICELIB functions
C
      DOUBLE PRECISION      CLIGHT
      DOUBLE PRECISION      VDOT
      DOUBLE PRECISION      VNORM

      LOGICAL               RETURN
      LOGICAL               VZERO

C
C     Local parameters
C
C
C     Let PHI be the (non-negative) rotation angle of the stellar
C     aberration correction; then SEPLIM is a limit on how close PHI
C     may be to zero radians while stellar aberration velocity is
C     computed analytically. When sin(PHI) is less than SEPLIM, the
C     velocity must be computed numerically.
C
      DOUBLE PRECISION      SEPLIM
      PARAMETER           ( SEPLIM = 1.D-6 )

C
C     Let TDELTA be the time interval, measured in seconds,
C     used for numerical differentiation of the stellar
C     aberration correction, when this is necessary.
C
      DOUBLE PRECISION      TDELTA
      PARAMETER           ( TDELTA = 1.D0 )

C
C     Local variables
C
      DOUBLE PRECISION      C
      DOUBLE PRECISION      DPHI
      DOUBLE PRECISION      DPTMAG
      DOUBLE PRECISION      DRHAT  ( 3 )
      DOUBLE PRECISION      DVP    ( 3 )
      DOUBLE PRECISION      DVPHAT ( 3 )
      DOUBLE PRECISION      EPTARG ( 3 )
      DOUBLE PRECISION      EVOBS  ( 3 )
      DOUBLE PRECISION      LCACC  ( 3 )
      DOUBLE PRECISION      LCVOBS ( 3 )
      DOUBLE PRECISION      PTARG  ( 3 )
      DOUBLE PRECISION      PTGMAG
      DOUBLE PRECISION      RHAT   ( 3 )
      DOUBLE PRECISION      S
      DOUBLE PRECISION      SAOFF  ( 3, 2 )
      DOUBLE PRECISION      SGN
      DOUBLE PRECISION      SRHAT  ( 6 )
      DOUBLE PRECISION      SVP    ( 6 )
      DOUBLE PRECISION      SVPHAT ( 6 )
      DOUBLE PRECISION      TERM1  ( 3 )
      DOUBLE PRECISION      TERM2  ( 3 )
      DOUBLE PRECISION      TERM3  ( 3 )
      DOUBLE PRECISION      VP     ( 3 )
      DOUBLE PRECISION      VPHAT  ( 3 )
      DOUBLE PRECISION      VTARG  ( 3 )

      INTEGER               I

C
C     Use discovery check-in.
C
      IF ( RETURN() ) THEN
         RETURN
      END IF

C
C     In the discussion below, the dot product of vectors X and Y
C     is denoted by
C
C        <X,Y>
C
C     The speed of light is denoted by the lower case letter "c." BTW,
C     variable names used here are case-sensitive: upper case "C"
C     represents a different quantity which is unrelated to the speed
C     of light.
C
C     Variable names ending in "HAT" denote unit vectors. Variable
C     names starting with "D" denote derivatives with respect to time.
C
C     We'll compute the correction SCORR and its derivative with
C     respect to time DSCORR for the reception case. In the
C     transmission case, we perform the same computation with the
C     negatives of the observer velocity and acceleration.
C
C     In the code below, we'll store the position and velocity portions
C     of the input observer-target state STARG in the variables PTARG
C     and VTARG, respectively.
C
C     Let VP be the component of VOBS orthogonal to PTARG. VP
C     is defined as
C
C         VOBS - < VOBS, RHAT > RHAT                                 (1)
C
C     where RHAT is the unit vector
C
C         PTARG/||PTARG||
C
C     Then
C
C        ||VP||/c                                                    (2)
C
C     is the magnitude of
C
C        s = sin( phi )                                              (3)
C
C     where phi is the stellar aberration correction angle. We'll
C     need the derivative with respect to time of (2).
C
C     Differentiating (1) with respect to time yields the
C     velocity DVP, where, letting
C
C        DRHAT  =  d(RHAT) / dt
C        VPHAT  =  VP      / ||VP||
C        DVPMAG =  d( ||VP|| ) / dt
C
C     we have
C
C        DVP = d(VP)/dt
C
C            = ACCOBS - (  ( <VOBS,DRHAT> + <ACCOBS, RHAT> )*RHAT
C                        +   <VOBS,RHAT>  * DRHAT                 )  (4)
C
C     and
C
C        DVPMAG = < DVP, VPHAT >                                     (5)
C
C     Now we can find the derivative with respect to time of
C     the stellar aberration angle phi:
C
C        ds/dt = d(sin(phi))/dt = d(phi)/dt * cos(phi)               (6)
C
C     Using (2) and (5), we have for positive phi,
C
C        ds/dt = (1/c)*DVPMAG = (1/c)*<DVP, VPHAT>                   (7)
C
C     Then for positive phi
C
C        d(phi)/dt = (1/cos(phi)) * (1/c) * <DVP, VPHAT>             (8)
C
C     Equation (8) is well-defined as along as VP is non-zero:
C     if VP is the zero vector, VPHAT is undefined. We'll treat
C     the singular and near-singular cases separately.
C
C     The aberration correction itself is a rotation by angle phi
C     from RHAT towards VP, so the corrected vector is
C
C        ( sin(phi)*VPHAT + cos(phi)*RHAT ) * ||PTARG||
C
C     and  we can express the offset of the corrected vector from
C     PTARG, which is the output SCORR, as
C
C        SCORR =
C
C        ( sin(phi)*VPHAT + (cos(phi)-1)*RHAT ) * ||PTARG||          (9)
C
C     Let DPTMAG be defined as
C
C        DPTMAG  =  d ( ||PTARG|| ) / dt                            (10)
C
C     Then the derivative with respect to time of SCORR is
C
C        DSCORR =
C
C             (      sin(phi)*DVPHAT
C
C                +   cos(phi)*d(phi)/dt * VPHAT
C
C                +  (cos(phi) - 1) * DRHAT
C
C                +  ( -sin(phi)*d(phi)/dt ) * RHAT   ) * ||PTARG||
C
C           + ( sin(phi)*VPHAT + (cos(phi)-1)*RHAT ) * DPTMAG       (11)
C
C
C     Computations begin here:
C
C     Split STARG into position and velocity components. Compute
C
C        RHAT
C        DRHAT
C        VP
C        DPTMAG
C
      IF ( XMIT ) THEN
         CALL VMINUS ( VOBS,   LCVOBS )
         CALL VMINUS ( ACCOBS, LCACC  )
      ELSE
         CALL VEQU   ( VOBS,   LCVOBS )
         CALL VEQU   ( ACCOBS, LCACC  )
      END IF

      CALL VEQU  ( STARG,      PTARG )
      CALL VEQU  ( STARG(4),   VTARG )

      CALL DVHAT ( STARG,      SRHAT )
      CALL VEQU  ( SRHAT,      RHAT  )
      CALL VEQU  ( SRHAT(4),   DRHAT )

      CALL VPERP ( LCVOBS, RHAT, VP    )

      DPTMAG = VDOT ( VTARG, RHAT )

C
C     Compute sin(phi) and cos(phi), which we'll call S and C
C     respectively. Note that phi is always close to zero for
C     realistic inputs (for which ||VOBS|| << CLIGHT), so the
C     cosine term is positive.
C
      S = VNORM(VP) / CLIGHT()

      C = SQRT (  MAX( 0.D0,  1 - S*S )  )

      IF ( C .EQ. 0.D0 ) THEN
C
C        C will be used as a divisor later (in the computation
C        of DPHI), so we'll put a stop to the problem here.
C
         CALL CHKIN  ( 'ZZSTELAB'                               )
         CALL SETMSG ( 'Cosine of the aberration angle is 0; '
     .   //            'this cannot occur for realistic '
     .   //            'observer velocities. This case can '
     .   //            'arise due to uninitialized inputs. '
     .   //            'This cosine value is used as a divisor '
     .   //            'in a later computation, so it must not '
     .   //            'be equal to zero.'                      )
        CALL SIGERR ( 'SPICE(DIVIDEBYZERO)'                     )
        CALL CHKOUT ( 'ZZSTELAB'                                )
        RETURN

      END IF

C
C     Compute the unit vector VPHAT and the stellar
C     aberration correction. We avoid relying on
C     VHAT's exception handling for the zero vector.
C
      IF ( VZERO(VP) ) THEN
         CALL CLEARD ( 3,  VPHAT )
      ELSE
         CALL VHAT   ( VP, VPHAT )
      END IF

C
C     Now we can use equation (9) to obtain the stellar
C     aberration correction SCORR:
C
C        SCORR =
C
C           ( sin(phi)*VPHAT + (cos(phi)-1)*RHAT ) * ||PTARG||
C
C
      PTGMAG = VNORM( PTARG )

      CALL VLCOM ( PTGMAG * S,           VPHAT,
     .             PTGMAG * (C - 1.D0),  RHAT,   SCORR )

C
C     Now we use S as an estimate of PHI to decide if we're
C     going to differentiate the stellar aberration correction
C     analytically or numerically.
C
C     Note that S is non-negative by construction, so we don't
C     need to use the absolute value of S here.
C
      IF ( S .GE. SEPLIM ) THEN
C
C        This is the analytic case.
C
C        Compute DVP---the derivative of VP with respect to time.
C        Recall equation (4):
C
C        DVP = d(VP)/dt
C
C            = ACCOBS - (  ( <VOBS,DRHAT> + <ACCOBS, RHAT> )*RHAT
C                        +   <VOBS,RHAT>  * DRHAT                 )
C
         CALL VLCOM3 ( 1.D0,                                      LCACC,
     .                 -VDOT(LCVOBS, DRHAT) - VDOT(LCACC, RHAT),  RHAT,
     .                 -VDOT(LCVOBS, RHAT ),                      DRHAT,
     .                 DVP                                             )

         CALL VHAT ( VP, VPHAT )

C
C        Now we can compute DVPHAT, the derivative of VPHAT:
C
         CALL VEQU  ( VP,        SVP    )
         CALL VEQU  ( DVP,       SVP(4) )

         CALL DVHAT ( SVP,       SVPHAT )
         CALL VEQU  ( SVPHAT(4), DVPHAT )

C
C        Compute the DPHI, the time derivative of PHI, using equation 8:
C
C           d(phi)/dt = (1/cos(phi)) * (1/c) * <DVP, VPHAT>
C
C
         DPHI = ( 1.D0 / ( C * CLIGHT() ) ) * VDOT( DVP, VPHAT )

C
C        At long last we've assembled all of the "ingredients" required
C        to compute DSCORR:
C
C           DSCORR =
C
C             (     sin(phi)*DVPHAT
C
C                +  cos(phi)*d(phi)/dt * VPHAT
C
C                +  (cos(phi) - 1) * DRHAT
C
C                +  ( -sin(phi)*d(phi)/dt ) * RHAT   ) * ||PTARG||
C
C                +  ( sin(phi)*VPHAT + (cos(phi)-1)*RHAT ) * DPTMAG
C
C
         CALL VLCOM  ( S,             DVPHAT,
     .                 C * DPHI,      VPHAT,  TERM1 )

         CALL VLCOM  ( C - 1.D0,      DRHAT,
     .                 (-S) * DPHI,   RHAT,   TERM2 )

         CALL VADD   ( TERM1,  TERM2, TERM3 )

         CALL VLCOM3 ( PTGMAG,                TERM3,
     .                 DPTMAG * S,            VPHAT,
     .                 DPTMAG * (C - 1.D0),   RHAT,    DSCORR )

      ELSE
C
C        This is the numeric case. We're going to differentiate
C        the stellar aberration correction offset vector using
C        a quadratic estimate.
C
         DO I = 1, 2
C
C           Set the sign of the time offset.
C
            IF ( I .EQ. 1 ) THEN
               SGN = -1.D0
            ELSE
               SGN =  1.D0
            END IF

C
C           Estimate the observer's velocity relative to the
C           solar system barycenter at the current epoch. We use
C           the local copies of the input velocity and acceleration
C           to make a linear estimate.
C
            CALL VLCOM ( 1.D0,        LCVOBS,
     .                   SGN*TDELTA,  LCACC,     EVOBS )

C
C           Estimate the observer-target vector. We use the
C           observer-target state velocity to make a linear estimate.
C
            CALL VLCOM ( 1.D0,        STARG,
     .                   SGN*TDELTA,  STARG(4),  EPTARG )

C
C           Let RHAT be the unit observer-target position.
C           Compute the component of the observer's velocity
C           that is perpendicular to the target position; call
C           this vector VP. Also compute the unit vector in
C           the direction of VP.
C
            CALL VHAT  ( EPTARG,  RHAT     )
            CALL VPERP ( EVOBS,   RHAT, VP )

            IF ( VZERO(VP) ) THEN
               CALL CLEARD ( 3,  VPHAT )
            ELSE
               CALL VHAT   ( VP, VPHAT )
            END IF

C
C           Compute the sine and cosine of the correction
C           angle.
C
            S = VNORM(VP) / CLIGHT()

            C = SQRT (  MAX( 0.D0,  1 - S*S )  )

C
C           Compute the vector offset of the correction.
C
            PTGMAG = VNORM( EPTARG )

            CALL VLCOM ( PTGMAG * S,           VPHAT,
     .                   PTGMAG * (C - 1.D0),  RHAT,   SAOFF(1,I) )
         END DO

C
C        Now compute the derivative.
C
         CALL QDERIV ( 3, SAOFF(1,1), SAOFF(1,2), TDELTA, DSCORR )

      END IF

C
C     At this point the correction offset SCORR and its derivative
C     with respect to time DSCORR are both set.
C
      END


module da_obs

   use da_define_structures, only : multi_level_type, y_type, iv_type, infa_type, &
      field_type, each_level_type,da_allocate_y, da_random_seed,da_allocate_y_rain, &
      da_allocate_y_radar
   use module_domain, only : domain, x_type

   use da_airep, only : da_transform_xtoy_airep, da_transform_xtoy_airep_adj
   use da_airsr, only : da_transform_xtoy_airsr, da_transform_xtoy_airsr_adj
   use da_bogus, only : da_transform_xtoy_bogus, da_transform_xtoy_bogus_adj
   use da_buoy, only : da_transform_xtoy_buoy,da_transform_xtoy_buoy_adj
   use da_control, only : use_shipsobs, use_synopobs, use_ssmt2obs, &
      use_soundobs,use_mtgirsobs,use_satemobs, use_profilerobs, use_pilotobs, &
      use_qscatobs,use_metarobs, use_polaramvobs, use_geoamvobs, &
      use_bogusobs,use_buoyobs, use_airsretobs, use_tamdarobs, trace_use, num_procs, &
      xmiss, missing_r, missing, use_airepobs,use_gpspwobs,use_gpsztdobs,use_gpsrefobs, &
      use_ssmt1obs,filtered_obs_unit,fmt_each,fmt_info,fmt_srfc, ide, jde, &
      pseudo_x, fg_format, fg_format_kma_global, fg_format_wrf_arw_regional,fg_format_wrf_nmm_regional, &
      missing_data, pseudo_var, pseudo_val,stdout, num_pseudo, pseudo_y, pseudo_z, &
      pseudo_err,obs_qc_pointer,myproc,rtm_option,rtm_option_rttov, &
      rtm_option_crtm,use_rad, base_temp, base_lapse, base_pres, &
      ob_format,ob_format_ascii,filename_len, trace_use_dull, &
      sound, mtgirs, synop, profiler, gpsref, gpseph, gpspw, polaramv, geoamv, ships, metar, &
      satem, radar, ssmi_rv, ssmi_tb, ssmt1, ssmt2, airsr, pilot, airep, sonde_sfc,rain, &
      bogus, buoy, qscat, tamdar, tamdar_sfc, pseudo, num_ob_indexes, its,ite,jds,jts,jte,ids, &
      write_mod_filtered_obs, radiance, use_varbc, obs_names, q_error_options,radar_rf_rscl,radar_rv_rscl, kts,kte,kds,kde, &
      use_gpsephobs
   ! use_crtm_kmatrix,use_crtm_kmatrix_fast
   use da_control, only : pseudo_tpw, pseudo_ztd, pseudo_ref, pseudo_uvtpq
   use da_define_structures, only : da_allocate_obs_info
#ifdef CRTM
   use da_crtm, only : da_transform_xtoy_crtm, da_transform_xtoy_crtm_adj
      !da_transform_xtoy_crtmk,da_transform_xtoy_crtmk_adj
      !da_transform_xtoy_crtmk_f, da_transform_xtoy_crtmk_f_adj
#endif
   use da_geoamv,    only : da_transform_xtoy_geoamv, da_transform_xtoy_geoamv_adj
   use da_gpspw,     only : da_transform_xtoy_gpspw,da_transform_xtoy_gpspw_adj, &
                            da_transform_xtoy_gpsztd,da_transform_xtoy_gpsztd_adj
   use da_gpsref,    only : da_transform_xtoy_gpsref,da_transform_xtoy_gpsref_adj
   use da_gpseph,    only : da_transform_xtoy_gpseph,da_transform_xtoy_gpseph_adj, &
      global_adj_ref, global_h_mean, global_h, global_xa_ref, global_ref, gps_rays
   use da_metar,     only : da_transform_xtoy_metar, da_transform_xtoy_metar_adj
   use da_physics,   only : da_tp_to_qs,da_get_q_error
   use da_pilot,     only : da_transform_xtoy_pilot,da_transform_xtoy_pilot_adj
   use da_polaramv,  only : da_transform_xtoy_polaramv, da_transform_xtoy_polaramv_adj
   use da_profiler,  only : da_transform_xtoy_profiler, da_transform_xtoy_profiler_adj
   use da_pseudo,    only : da_transform_xtoy_pseudo, da_transform_xtoy_pseudo_adj
   use da_qscat,     only : da_transform_xtoy_qscat,da_transform_xtoy_qscat_adj
   use da_radar,     only : da_transform_xtoy_radar,da_transform_xtoy_radar_adj
   use da_rain,      only : da_transform_xtoy_rain,da_transform_xtoy_rain_adj
   use da_reporting, only : da_error, message, da_warning, da_message
#ifdef RTTOV
   use da_rttov,     only : da_transform_xtoy_rttov,da_transform_xtoy_rttov_adj
#endif
   use da_satem,     only : da_transform_xtoy_satem, da_transform_xtoy_satem_adj
   use da_ships,     only : da_transform_xtoy_ships, da_transform_xtoy_ships_adj
   use da_sound,     only : da_transform_xtoy_sound, da_transform_xtoy_sonde_sfc, &
      da_transform_xtoy_sound_adj, da_transform_xtoy_sonde_sfc_adj
   use da_mtgirs,    only : da_transform_xtoy_mtgirs, da_transform_xtoy_mtgirs_adj
  use da_tamdar,    only : da_transform_xtoy_tamdar, da_transform_xtoy_tamdar_adj, &
                            da_transform_xtoy_tamdar_sfc, da_transform_xtoy_tamdar_sfc_adj
   use da_ssmi,      only : da_transform_xtoy_ssmt1, da_transform_xtoy_ssmt2, &
      da_transform_xtoy_ssmi_tb, da_transform_xtoy_ssmi_rv, &
      da_transform_xtoy_ssmi_tb_adj, da_transform_xtoy_ssmi_rv_adj, &
      da_transform_xtoy_ssmt1_adj, da_transform_xtoy_ssmt2_adj
   use da_synop,     only : da_transform_xtoy_synop,da_transform_xtoy_synop_adj
   use da_tools_serial,    only : da_free_unit, da_get_unit
   use da_tools,     only : da_add_noise, da_add_noise_new,da_random_omb, &
                            da_geo2msl1, da_msl2geo1
   use da_tracing,   only : da_trace_entry, da_trace_exit
   use module_dm,    only : wrf_dm_sum_real, wrf_dm_sum_reals

   implicit none

contains

#include "da_obs_proc_station.inc"
#include "da_transform_xtoy.inc"
#include "da_transform_xtoy_adj.inc"
#include "da_add_noise_to_ob.inc"
#include "da_check_missing.inc"
#include "da_fill_obs_structures.inc"
#include "da_fill_obs_structures_radar.inc"
#include "da_fill_obs_structures_rain.inc"
#include "da_random_omb_all.inc"
#include "da_store_obs_grid_info.inc"
#include "da_store_obs_grid_info_rad.inc"
#include "da_count_filtered_obs.inc"
#include "da_obs_sensitivity.inc"
#include "da_set_obs_missing.inc"
#include "da_set_3d_obs_missing.inc"

end module da_obs


! Name = ARPIT KUMAR JAIN ROLLNO = 180122009
PROGRAM  question1
    IMPLICIT NONE

    integer :: a, b, c, largest
    ! Reading 3 integer a, b and c from screen
    read *, a, b, c

    !  Finding maximum of these 3 integer
    if(a >= b .and. a >= c) then
        largest = a
    else if(b >= a .and. b >= c) then
        largest = b
    else
        largest = c
    endif

    ! printing the largest value on screen
    print *, largest

    STOP
END PROGRAM


Subroutine newka(icase, irun, iseed, dt, nt, ictrl, i1, i2, srt, pcx, pcy, pcz, iblock)
  Parameter (maxstr=150001, maxr=1)
  Parameter (aka=0.498)
  Common /aa/r(3, maxstr)
  Common /bb/p(3, maxstr)
  Common /cc/e(maxstr)
  Common /ee/id(maxstr), lb(maxstr)
  Common /bg/betax, betay, betaz, gamma
  Common /nn/nnn
  Common /run/num
  Common /pa/rpion(3, maxstr, maxr)
  Common /pb/ppion(3, maxstr, maxr)
  Common /pc/epion(maxstr, maxr)
  Common /pd/lpion(maxstr, maxr)
  Common /rndf77/nseed
  Save
  Logical lb1bn, lb2bn, lb1mn, lb2mn
  Logical lb1bn1, lb2bn1, lb1bn0, lb2bn0
  Logical lb1mn0, lb2mn0, lb1mn1, lb2mn1
  Logical lb1mn2, lb2mn2
  icase = -1
  nchrg = -100
  ictrl = 1
  lb1 = lb(i1)
  lb2 = lb(i2)
  em1 = e(i1)
  em2 = e(i2)
  lb1bn = lb1 == 1 .Or. lb1 == 2 .Or. (lb1>5 .And. lb1<=13)
  lb2bn = lb2 == 1 .Or. lb2 == 2 .Or. (lb2>5 .And. lb2<=13)
  lb1bn0 = lb1 == 2 .Or. lb1 == 7 .Or. lb1 == 10 .Or. lb1 == 12
  lb2bn0 = lb2 == 2 .Or. lb2 == 7 .Or. lb2 == 10 .Or. lb2 == 12
  lb1bn1 = lb1 == 1 .Or. lb1 == 8 .Or. lb1 == 11 .Or. lb1 == 13
  lb2bn1 = lb2 == 1 .Or. lb2 == 8 .Or. lb2 == 11 .Or. lb2 == 13
  lb1mn = em1 < 0.2 .Or. lb1 == 0 .Or. (lb1>=25 .And. lb1<=29)
  lb2mn = em2 < 0.2 .Or. lb2 == 0 .Or. (lb2>=25 .And. lb2<=29)
  lb1mn0 = lb1 == 0 .Or. lb1 == 4 .Or. lb1 == 26 .Or. lb1 == 28 .Or. lb1 == 29
  lb2mn0 = lb2 == 0 .Or. lb2 == 4 .Or. lb2 == 26 .Or. lb2 == 28 .Or. lb2 == 29
  lb1mn1 = lb1 == 5 .Or. lb1 == 27
  lb2mn1 = lb2 == 5 .Or. lb2 == 27
  lb1mn2 = lb1 == 3 .Or. lb1 == 25
  lb2mn2 = lb2 == 3 .Or. lb2 == 25
  If (lb1bn .And. lb2bn) Then
    icase = 1
    sig = 40.
    If (lb1==9 .And. lb2==9) Then
      nchrg = 4
    End If
    If ((lb1bn1 .And. lb2==9) .Or. (lb2bn1 .And. lb1==9)) Then
      nchrg = 3
    End If
    If ((lb1bn0 .And. lb2==9) .Or. (lb2bn0 .And. lb1==9) .Or. (lb1bn1 .And. lb2bn1)) Then
      nchrg = 2
    End If
    If ((lb1bn1 .And. lb2bn0) .Or. (lb1==6 .And. lb2==9) .Or. (lb2bn1 .And. lb1bn0) .Or. (lb2==6 .And. lb1==9)) Then
      nchrg = 1
    End If
    If ((lb1bn0 .And. lb2bn0) .Or. (lb1bn1 .And. lb2==6) .Or. (lb2bn1 .And. lb1==6)) Then
      nchrg = 0
    End If
    If ((lb1bn0 .And. lb2==6) .Or. (lb2bn0 .And. lb1==6)) Then
      nchrg = -1
    End If
    If (lb1==6 .And. lb2==6) Then
      nchrg = -2
    End If
    If (nchrg>=-1 .And. nchrg<=2) Then
      brsig = x2kaon(srt)
    Else
      brsig = 0.0
    End If
    brsig = 2.0*brsig
  End If
  If ((lb1bn .And. lb2mn) .Or. (lb2bn .And. lb1mn)) Then
    icase = 2
    sig = 20.
    sigma0 = pinsg0(srt)
    brsig = 0.0
    If ((lb1bn1 .And. lb2mn0) .Or. (lb2bn1 .And. lb1mn0) .Or. (lb1bn0 .And. lb2mn1) .Or. (lb2bn0 .And. lb1mn1) .Or. (lb1==9 .And. lb2mn2) .Or. (lb2==9 .And. lb1mn2)) Then
      nchrg = 1
      If (lb1bn1 .Or. lb2bn1) brsig = 0.5*sigma0
      If (lb1bn0 .Or. lb2bn0) brsig = 2.0*sigma0
    End If
    If ((lb1bn0 .And. lb2mn0) .Or. (lb2bn0 .And. lb1mn0) .Or. (lb1bn1 .And. lb2mn2) .Or. (lb2bn1 .And. lb1mn2) .Or. (lb1==6 .And. lb2mn1) .Or. (lb2==6 .And. lb1mn1)) Then
      nchrg = 0
      If (lb1bn1 .Or. lb2bn1) Then
        brsig = 3.0*sigma0
        ratiok = 2./3.
      End If
      If (lb1bn0 .Or. lb2bn0) Then
        brsig = 2.5*sigma0
        ratiok = 0.2
      End If
    End If
    If ((lb1bn0 .And. lb2mn2) .Or. (lb2bn0 .And. lb1mn2) .Or. (lb1==6 .And. lb2mn0) .Or. (lb2==6 .And. lb1mn0)) Then
      nchrg = -1
      If (lb1bn0 .Or. lb2bn0) brsig = sigma0
    End If
    If ((lb1==6 .And. lb2mn2) .Or. (lb2==6 .And. lb1mn2)) Then
      nchrg = -2
    End If
    If ((lb1bn1 .And. lb2mn1) .Or. (lb2bn1 .And. lb1mn1) .Or. (lb1==9 .And. lb2mn0) .Or. (lb2==9 .And. lb1mn0)) Then
      nchrg = 2
    End If
    If (nchrg>=-2 .And. nchrg<=2) Then
      brsig = 3.0*sigma0
    End If
  End If
  If ((lb1bn .And. (lb2==21 .Or. lb2==-30)) .Or. (lb2bn .And. (lb1==21 .Or. lb1==-30))) Then
    bmass = 0.938
    If (srt<=(bmass+aka)) Then
      pkaon = 0.
    Else
      pkaon = sqrt(((srt**2-(aka**2+bmass**2))/2./bmass)**2-aka**2)
    End If
    sig = 0.
    If (lb1==1 .Or. lb2==1 .Or. lb1==8 .Or. lb2==8 .Or. lb1==11 .Or. lb2==11 .Or. lb1==13 .Or. lb2==13) Then
      nchrg = 0
      sigela = akpel(pkaon)
      sigsgm = 3.*akpsgm(pkaon)
      sig = sigela + sigsgm + akplam(pkaon)
    End If
    If (lb1==2 .Or. lb2==2 .Or. lb1==7 .Or. lb2==7 .Or. lb1==10 .Or. lb2==10 .Or. lb1==12 .Or. lb2==12) Then
      nchrg = -1
      sigela = aknel(pkaon)
      sigsgm = 2.*aknsgm(pkaon)
      sig = sigela + sigsgm + aknlam(pkaon)
    End If
    If (lb1==6 .Or. lb2==6) Then
      nchrg = -2
      sigela = aknel(pkaon)
      sigsgm = aknsgm(pkaon)
      sig = sigela + sigsgm
    End If
    If (lb1==9 .Or. lb2==9) Then
      nchrg = 1
      sigela = akpel(pkaon)
      sigsgm = 2.*akpsgm(pkaon)
      sig = sigela + sigsgm + akplam(pkaon)
    End If
    sigela = 0.5*(akpel(pkaon)+aknel(pkaon))
    sigsgm = 1.5*akpsgm(pkaon) + aknsgm(pkaon)
    sig = sigela + sigsgm + akplam(pkaon)
    If (sig>1.E-7) Then
      icase = 3
      brel = sigela/sig
      brsgm = sigsgm/sig
      brsig = sig
    End If
  End If
  If (((lb1>=14 .And. lb1<=17) .And. (lb2>=3 .And. lb2<=5)) .Or. ((lb2>=14 .And. lb2<=17) .And. (lb1>=3 .And. lb1<=5))) Then
    nchrg = -100
    If ((lb1==15 .And. (lb2==3 .Or. lb2==25)) .Or. (lb2==15 .And. (lb1==3 .Or. lb1==25))) Then
      nchrg = -2
      bmass = 1.232
    End If
    If ((lb1==15 .And. lb2mn0) .Or. (lb2==15 .And. lb1mn0) .Or. ((lb1==14 .Or. lb1==16) .And. (lb2==3 .Or. lb2==25)) .Or. ((lb2==14 .Or. lb2==16) .And. (lb1==3 .Or. lb1==25))) Then
      nchrg = -1
      bmass = 0.938
    End If
    If ((lb1==15 .And. (lb2==5 .Or. lb2==27)) .Or. (lb2==15 .And. (lb1==5 .Or. lb1==27)) .Or. (lb1==17 .And. (lb2==3 .Or. lb2==25)) .Or. (lb2==17 .And. (lb1==3 .Or. lb1==25)) .Or. ((lb1==14 .Or. lb1==16) .And. lb2mn0) .Or. ((lb2==14 .Or. lb2==16) .And. lb1mn0)) Then
      nchrg = 0
      bmass = 0.938
    End If
    If ((lb1==17 .And. lb2mn0) .Or. (lb2==17 .And. lb1mn0) .Or. ((lb1==14 .Or. lb1==16) .And. (lb2==5 .Or. lb2==27)) .Or. ((lb2==14 .Or. lb2==16) .And. (lb1==5 .Or. lb1==27))) Then
      nchrg = 1
      bmass = 1.232
    End If
    sig = 0.
    If (nchrg/=-100 .And. srt>(aka+bmass)) Then
      icase = 4
      pkaon = sqrt(((srt**2-(aka**2+0.938**2))/2./0.938)**2-aka**2)
      If (lb1==14 .Or. lb2==14) Then
        If (nchrg>=0) sigma0 = akplam(pkaon)
        If (nchrg<0) sigma0 = aknlam(pkaon)
      Else
        If (nchrg>=0) sigma0 = akpsgm(pkaon)
        If (nchrg<0) sigma0 = aknsgm(pkaon)
        sigma0 = 1.5*akpsgm(pkaon) + aknsgm(pkaon)
      End If
      sig = (srt**2-(aka+bmass)**2)*(srt**2-(aka-bmass)**2)/(srt**2-(em1+em2)**2)/(srt**2-(em1-em2)**2)*sigma0
      If (nchrg==-2 .Or. nchrg==2) sig = 2.*sig
      If (lb1==14 .Or. lb2==14) Then
        sig = 4.0/3.0*sig
      Else If (nchrg==-2 .Or. nchrg==2) Then
        sig = 8.0/9.0*sig
      Else
        sig = 4.0/9.0*sig
      End If
      brsig = sig
      If (sig<1.E-7) sig = 1.E-7
    End If
    icase = 4
    brsig = sig
    sigela = 10.
    sig = sig + sigela
    brel = sigela/sig
  End If
  If (icase==-1) Then
    ictrl = -1
    Return
  End If
  px1cm = pcx
  py1cm = pcy
  pz1cm = pcz
  ds = sqrt(sig/31.4)
  dsr = ds + 0.1
  ec = (em1+em2+0.02)**2
  Call distce(i1, i2, dsr, ds, dt, ec, srt, ic, px1cm, py1cm, pz1cm)
  If (ic==-1) Then
    ictrl = -1
    Return
  End If
  ik = 0
  ik0 = 0
  ik1 = 0
  ik2 = 0
  ik3 = 0
  il = 0
  im = 0
  im3 = 0
  im4 = 0
  in = 0
  inpion = 0
  ipipi = 0
  sgsum = 0.
  sgsum1 = 0.
  sgsum3 = 0.
  If (icase==1) Then
    ik = ik + 1
    If (srt>2.8639) Then
      ik0 = ik0 + 1
      If (em1<1.0 .And. em2<1.0) Then
        ik1 = ik1 + 1
        sgsum1 = sgsum1 + brsig
      End If
      If (em1>1.0 .And. em2>1.0) Then
        ik3 = ik3 + 1
        sgsum3 = sgsum3 + brsig
      End If
      If (em1>1.0 .And. em2<1.0) ik2 = ik2 + 1
      If (em1<1.0 .And. em2>1.0) ik2 = ik2 + 1
      sgsum = sgsum + brsig
    End If
  End If
  If (icase==2) inpion = inpion + 1
  If (icase==5) ipipi = ipipi + 1
  If (ranart(nseed)>(brsig/sig)) Then
    ictrl = -1
    Return
  End If
  il = il + 1
  If (icase==1) Then
    in = in + 1
    Call nnkaon(irun, iseed, ictrl, i1, i2, iblock, srt, pcx, pcy, pcz, nchrg)
  End If
  If (icase==2) Then
    im = im + 1
    Call npik(irun, iseed, dt, nt, ictrl, i1, i2, srt, pcx, pcy, pcz, nchrg, ratiok, iblock)
  End If
  If (icase==3) Then
    im3 = im3 + 1
    Call kaonn(brel, brsgm, irun, iseed, dt, nt, ictrl, i1, i2, iblock, srt, pcx, pcy, pcz, nchrg)
  End If
  If (icase==4) Then
    im4 = im4 + 1
    If (ranart(nseed)<brel) Then
      ielstc = 1
    Else
      ielstc = 0
    End If
    Call pihypn(ielstc, irun, iseed, dt, nt, ictrl, i1, i2, srt, pcx, pcy, pcz, nchrg, iblock)
  End If
  Return
End Subroutine newka


!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  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, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      subroutine extinc ( pmsa   , fl     , ipoint , increm , noseg  ,
     &                    noflux , iexpnt , iknmrk , noq1   , noq2   ,
     &                    noq3   , noq4   )
!>\file
!>       Calculation total and partial extinction coefficients

!
!     This module calculates the total and partial extinction coeffcients,
!     optionally with additional module UITZICHT
!     In input DOC has replaced DisHum for UITZICHT
!
!     Logical Units : -

!     Modules called : -

!     Name     Type   Library
!     ------   -----  ------------
!
      IMPLICIT NONE
!
      REAL     PMSA  ( * ) , FL    (*)
      INTEGER  IPOINT(38) , INCREM(38) , NOSEG , NOFLUX,
     +         IEXPNT(4,*) , IKNMRK(*) , NOQ1, NOQ2, NOQ3, NOQ4
!
!     Local declaration
!
      REAL A1    !  R*4 1 I specific ext. inorganic suspended matter 1  [m2/gDM]
      REAL A2    !  R*4 1 I specific ext. inorganic suspended matter 2  [m2/gDM]
      REAL A3    !  R*4 1 I specific ext. inorganic suspended matter 3  [m2/gDM]
      REAL EXT    ! R*4 1 O total extinction                               [1/m]
      REAL EXTIM  ! R*4 1 O calculated extinction IM                       [1/m]
      REAL EXTPOC ! R*4 1 O extinction POC                                 [1/m]
      REAL EXTDOC ! R*4 1 O extinction DOC                                 [1/m]
      REAL EXT0    !R*4 1 I background extinction                          [1/m]
      REAL EXTALG  !R*4 1 I extinction algae                               [1/m]
      REAL EXTMAC  !R*4 1 I extinction macrophytes                         [1/m]
      REAL EXTSAL  !R*4 1 O extinction DOC for fresh water fraction        [1/m]
      REAL AIM1    !R*4 1 I suspended solids  fraction 1                [gDM/m3]
      REAL AIM2    !R*4 1 I suspended solids  fraction 2                [gDM/m3]
      REAL AIM3    !R*4 1 I suspended solids  fraction 3                [gDM/m3]
      REAL POC1  !  R*4 1 I fast decomposing detritus                    [gC/m3]
      REAL POC2  !  R*4 1 I medium decomposing detritus                  [gC/m3]
      REAL POC3  !  R*4 1 I slow decomposing detritus                    [gC/m3]
      REAL POC4  !  R*4 1 I refractory detritus                          [gC/m3]
      INTEGER SW_UIT  ! Extinction by UITZICHT on (1) or Off (0)             [-]
      REAL DOC     ! R*4 1 I dissolved organic carbon                    [gC/m3]
      REAL ADOC    ! R*4 1 I Specific extinction of DOC                  [m2/gC]
      REAL DIEP1   ! R*4 1 I argument UITZICHT
      REAL DIEP2   ! R*4 1 I argument UITZICHT
      REAL CORCHL  ! R*4 1 I argument UITZICHT
      REAL C_DET   ! R*4 1 I argument UITZICHT
      REAL C_GL1   ! R*4 1 I argument UITZICHT
      REAL C_GL2   ! R*4 1 I argument UITZICHT
      REAL HELHUM  ! R*4 1 I argument UITZICHT
      REAL TAU     ! R*4 1 I argument UITZICHT
      REAL ANGLE   ! R*4 1 I argument UITZICHT
      REAL DETCDM  ! R*4 1 I dry matter carbon ratio detritus              [g/g]
      REAL XTSAL0  ! R*4 1 I extra VL extinction at Salinity = 0           [1/m]
      REAL SALMAX  ! R*4 1 I salinity value for extra extinction = 0      [g/kg]
      REAL SALIN   ! R*4 1 I actual salinity                              [g/kg]
      REAL APOC1   ! R*4 1 I specific extintion POC1                [1/m/(G/M3)]
      REAL APOC2   ! R*4 1 I specific extintion POC2                [1/m/(G/M3)]
      REAL APOC3   ! R*4 1 I specific extintion POC3                [1/m/(G/M3)]
      REAL APOC4   ! R*4 1 I specific extintion POC4                [1/m/(G/M3)]
!
      REAL CHLORP, DETRIC, GLOEIR, AH_380
      REAL SECCHI, D_1   , EXTP_D, EXTDET, EXTGL, EXTHUM
      INTEGER      IFLUX, ISEG
!
      INTEGER  IPNT(38)
      INTEGER  NR_MES
      SAVE     NR_MES
      DATA     NR_MES / 0 /
!
      IPNT = IPOINT
      IFLUX = 0
!
      DO 9000 ISEG = 1 , NOSEG
!!    CALL DHKMRK(1,IKNMRK(ISEG),IKMRK1)
!!    IF (IKMRK1.EQ.1) THEN
      IF (BTEST(IKNMRK(ISEG),0)) THEN
!
      A1        = PMSA(IPNT(1))
      A2        = PMSA(IPNT(2))
      A3        = PMSA(IPNT(3))
      APOC1     = PMSA(IPNT(4))
      EXT0      = PMSA(IPNT(5))
      EXTALG    = PMSA(IPNT(6))
      EXTMAC    = PMSA(IPNT(7))
      AIM1      = PMSA(IPNT(8))
      AIM2      = PMSA(IPNT(9))
      AIM3      = PMSA(IPNT(10))
      POC1      = PMSA(IPNT(11))
      POC2      = PMSA(IPNT(12))
      SW_UIT    = NINT(PMSA(IPNT(13)))
      DOC       = PMSA(IPNT(14))
      ADOC      = PMSA(IPNT(15))
      DIEP1     = PMSA(IPNT(16))
      DIEP2     = PMSA(IPNT(17))
      CORCHL    = PMSA(IPNT(18))
      C_DET     = PMSA(IPNT(19))
      C_GL1     = PMSA(IPNT(20))
      C_GL2     = PMSA(IPNT(21))
      HELHUM    = PMSA(IPNT(22))
      TAU       = PMSA(IPNT(23))
      ANGLE     = PMSA(IPNT(24))
      DETCDM    = PMSA(IPNT(25))
      XTSAL0    = PMSA(IPNT(26))
      SALIN     = PMSA(IPNT(27))
      SALMAX    = PMSA(IPNT(28))
      APOC2     = PMSA(IPNT(29))
      APOC3     = PMSA(IPNT(30))
      APOC4     = PMSA(IPNT(31))
      POC3      = PMSA(IPNT(32))
      POC4      = PMSA(IPNT(33))
!
      IF (SW_UIT.EQ.0) THEN
!
!  calculate extinction coefficients - no UITZICHT
!
        EXTIM  =  A1 * AIM1  + A2 * AIM2 + A3 * AIM3
        EXTPOC =  APOC1*POC1 + APOC2*POC2 + APOC3*POC3 + APOC4*POC4
        EXTDOC =  ADOC*DOC
        SALIN  =  MIN(SALIN,SALMAX)
        SALIN  =  MAX(SALIN,0.0)
        EXTSAL =  XTSAL0 * (1.0-SALIN/SALMAX)
        EXT    =  EXT0 + EXTIM + EXTPOC + EXTDOC + EXTALG  + EXTMAC
     J            + EXTSAL
!
        IF ( EXT .LT. 1.0E-20 ) THEN
           IF ( NR_MES .LT. 25 ) THEN
              NR_MES = NR_MES + 1
              WRITE(*,*) ' WARNING : zero or negative extinction'
              WRITE(*,*) ' Extinction due to inorganic matter:',EXTIM
              WRITE(*,*) ' Extinction due to organic matter  :',EXTPOC
              WRITE(*,*) ' Extinction due to algae           :',EXTALG
              WRITE(*,*) ' Background extinction             :',EXT0
              WRITE(*,*) ' Extinction by macrophytes         :',EXTMAC
              WRITE(*,*) ' In segment number                 :',ISEG
              WRITE(*,*) ' Background extinction is assumed.'
           ENDIF
           IF ( NR_MES .EQ. 25 ) THEN
              NR_MES = NR_MES + 1
              WRITE(*,*) ' 25 WARNINGS on extinction'
              WRITE(*,*) ' Further messages on extinction surpressed'
           ENDIF
           IF ( EXT0 .LT. 1.E-20 ) THEN
              EXT = 1.E-15
           ELSE
              EXT = EXT0
           ENDIF
        ENDIF
!
      ELSE
!
!  calculate extinction coefficients - with UITZICHT
!
        CHLORP = 0.0
        DETRIC = MAX ( 0.0, DETCDM * (POC1 +POC2 +POC3 + POC4))
        AH_380 = DOC*ADOC
        GLOEIR = AIM1 + AIM2 + AIM3
!
!  total extinction coefficient exclusive of algae, macrophytes and background
!
        CALL UIT_ZI( DIEP1 , DIEP2 , ANGLE , C_GL1 , C_GL2 ,
     1               C_DET , HELHUM, TAU   , CORCHL, CHLORP,
     2               DETRIC, GLOEIR, AH_380, SECCHI, D_1   ,
     3               EXT   , EXTP_D,.FALSE.)
!
!  total extinction coefficient of detritus
!
        CALL UIT_ZI( DIEP1 , DIEP2 , ANGLE , C_GL1 , C_GL2 ,
     1               C_DET , HELHUM, TAU   , CORCHL, CHLORP,
     2               0.0   , GLOEIR, AH_380, SECCHI, D_1   ,
     3               EXTDET, EXTP_D,.FALSE.)
        EXTDET = EXT - EXTDET
!
!  total extinction coefficient of inorganic sediment
!
        CALL UIT_ZI( DIEP1 , DIEP2 , ANGLE , C_GL1 , C_GL2 ,
     1               C_DET , HELHUM, TAU   , CORCHL, CHLORP,
     2               DETRIC, 0.0   , AH_380, SECCHI, D_1   ,
     3               EXTGL , EXTP_D,.FALSE.)
        EXTGL  = EXT - EXTGL
!
!  total extinction coefficient of DOC (humic acids)
!
        CALL UIT_ZI( DIEP1 , DIEP2 , ANGLE , C_GL1 , C_GL2 ,
     1               C_DET , HELHUM, TAU   , CORCHL, CHLORP,
     2               DETRIC, GLOEIR, 0.0   , SECCHI, D_1   ,
     3               EXTHUM, EXTP_D,.FALSE.)
        EXTHUM = EXT - EXTHUM
!
        EXTIM  =  EXTGL
        EXTPOC =  EXTDET
        EXTDOC =  EXTHUM
        EXTSAL =  0.0
        EXT    =  EXT0 + EXT + EXTALG + EXTMAC
!
      ENDIF
!
      PMSA(IPNT(34)) = EXT
      PMSA(IPNT(35)) = EXTIM
      PMSA(IPNT(36)) = EXTPOC
      PMSA(IPNT(37)) = EXTDOC
      PMSA(IPNT(38)) = EXTSAL
!
      ENDIF
!
      IFLUX = IFLUX + NOFLUX
      IPNT  = IPNT  + INCREM
!
 9000 CONTINUE
!
      RETURN
!
      END


! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! H0 X
! H0 X   libAtoms+QUIP: atomistic simulation library
! H0 X
! H0 X   Portions of this code were written by
! H0 X     Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode,
! H0 X     Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield.
! H0 X
! H0 X   Copyright 2006-2010.
! H0 X
! H0 X   These portions of the source code are released under the GNU General
! H0 X   Public License, version 2, http://www.gnu.org/copyleft/gpl.html
! H0 X
! H0 X   If you would like to license the source code under different terms,
! H0 X   please contact Gabor Csanyi, gabor@csanyi.net
! H0 X
! H0 X   Portions of this code were written by Noam Bernstein as part of
! H0 X   his employment for the U.S. Government, and are not subject
! H0 X   to copyright in the USA.
! H0 X
! H0 X
! H0 X   When using this software, please cite the following reference:
! H0 X
! H0 X   http://www.libatoms.org
! H0 X
! H0 X  Additional contributions by
! H0 X    Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras
! H0 X
! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
!X
!X Force Mixing header stuff to be included in Potential.f95
!X
!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

  public :: Potential_FM
  type Potential_FM

     type(Potential), pointer :: mmpot => null()
     type(Potential), pointer :: qmpot => null()
     type(MPI_context) :: mpi

     character(STRING_LENGTH) :: init_args_str

     logical  :: minimise_mm      !% Should classical degrees of freedom be minimised in each calc?
     logical  :: calc_weights     !% Should weights be recalculated on each call to 'calc()'
     character(STRING_LENGTH) :: method  !% What fit method to use. Options are:
     !% \begin{itemize}
     !%  \item 'lotf_adj_pot_svd' --- LOTF using SVD to optimised the Adj Pot
     !%  \item 'lotf_adj_pot_minim' --- LOTF using conjugate gradients to optimise the Adj Pot
     !%  \item 'conserve_momentum' --- divide the total force on QM region over the fit atoms to conserve momentum
     !%  \item 'force_mixing' --- force mixing with details depending on values of
     !%      'buffer_hops', 'transtion_hops' and 'weight_interpolation'
     !%  \item 'force_mixing_abrupt' --- simply use QM forces on QM atoms and MM forces on MM atoms
     !%      (shorthand for 'method=force_mixing buffer_hops=0 transition_hops=0')
     !%  \item 'force_mixing_smooth' --- use QM forces in QM region, MM forces in MM region and
     !%    linearly interpolate in buffer region  (shorthand for 'method=force_mixing weight_interpolation=hop_ramp')
     !%  \item 'force_mixing_super_smooth' --- as above, but weight forces on each atom by distance from
     !%    centre of mass of core region (shorthand for 'method=force_mixing weight_interpolation=distance_ramp')
     !% \end{itemize}
     !% Default method is 'conserve_momentum'.
     character(STRING_LENGTH) :: run_suffix   !% string to append to 'hybrid_mark' for actual hybrid_mark property
     real(dp) :: mm_reweight      !% Factor by which to reweight classical forces in embed zone
     character(STRING_LENGTH) :: conserve_momentum_weight_method   !% Weight method to use with 'method=conserve_momentum'. Should be one of
                                                                  !% 'uniform' (default), 'mass', 'mass^2' or 'user',
                                                                  !% with the last referring to a 'conserve_momentum_weight'
                                                                  !% property in the Atoms object.
     character(STRING_LENGTH) :: mm_args_str !% Args string to be passed to 'calc' method of 'mmpot'
     character(STRING_LENGTH) :: qm_args_str !% Args string to be passed to 'calc' method of 'qmpot'
     integer :: qm_little_clusters_buffer_hops !% Number of bond hops used for buffer region for qm calcs with little clusters
     logical :: use_buffer_for_fitting !% Whether to generate the fit region or just use the buffer as the fit region. Only for method=conserve_momentum
     integer :: fit_hops !% Number of bond hops used for fit region. Applies to 'conserve_momentum' and 'lotf_*' methods only.
     logical :: add_cut_H_in_fitlist !% Whether to extend the fit region where a cut hydrogen is cut after the fitlist selection.
                                     !% This will ensure to only include whole water molecules in the fitlist.
     logical :: randomise_buffer !% If true, then positions of outer layer of buffer atoms will be randomised slightly. Default false.
     logical :: save_forces !% If true, save MM, QM and total forces as properties in the Atoms object (default true)

     integer :: lotf_spring_hops  !% Maximum lengths of springs for LOTF 'adj_pot_svd' and 'adj_pot_minim' methods (default is 2).
     character(STRING_LENGTH) :: lotf_interp_order !% Interpolation order: should be one of 'linear', 'quadratic', or 'cubic'. Default is 'linear'.
     logical :: lotf_interp_space !% Do spatial rather than temporal interpolation of adj pot parameters. Default is false.
     logical :: lotf_nneighb_only !% If true (which is the default), uses nearest neigbour hopping to determine fit atoms
     logical :: do_rescale_r !% If true rescale positions in QM region by r_scale_pot1
     logical :: do_rescale_E !% If true rescale energies in QM region by E_scale_pot1
     real(dp) :: r_scale_pot1 !% Rescale positions in QM region by this factor
     real(dp) :: E_scale_pot1 !% Rescale energy in QM region by this factor

     character(STRING_LENGTH) :: minim_mm_method
     real(dp)      :: minim_mm_tol, minim_mm_eps_guess
     integer       :: minim_mm_max_steps
     character(STRING_LENGTH) :: minim_mm_linminroutine
     logical       :: minim_mm_do_pos, minim_mm_do_lat
     logical       :: minim_mm_do_print

     character(STRING_LENGTH) :: minim_mm_args_str

     type(Dictionary) :: create_hybrid_weights_params !% extra arguments to pass create_hybrid_weights

     type(Potential), pointer :: relax_pot
     type(Inoutput), pointer :: minim_inoutput_movie
     type(CInoutput), pointer :: minim_cinoutput_movie

     type(Table) :: embedlist, fitlist

  end type Potential_FM

  interface Initialise
     module procedure Potential_FM_initialise
  end interface

  interface Finalise
     module procedure Potential_FM_Finalise
  end interface

  interface Print
     module procedure Potential_FM_Print
  end interface

  interface Cutoff
     module procedure Potential_FM_Cutoff
  end interface

  interface Calc
     module procedure Potential_FM_Calc
  end interface