! KGEN-generated Fortran source file
!
! Filename    : rrlw_kg03.f90
! Generated at: 2015-07-06 23:28:44
! KGEN version: 0.4.13

    MODULE rrlw_kg03
        USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check
        USE shr_kind_mod, ONLY: r8 => shr_kind_r8
        !      use parkind ,only : jpim, jprb
        IMPLICIT NONE
        !-----------------------------------------------------------------
        ! rrtmg_lw ORIGINAL abs. coefficients for interval 3
        ! band 3:  500-630 cm-1 (low - h2o,co2; high - h2o,co2)
        !
        ! Initial version:  JJMorcrette, ECMWF, jul1998
        ! Revised: MJIacono, AER, jun2006
        !-----------------------------------------------------------------
        !
        !  name     type     purpose
        !  ----   : ----   : ---------------------------------------------
        !fracrefao: real
        !fracrefbo: real
        ! kao     : real
        ! kbo     : real
        ! kao_mn2o: real
        ! kbo_mn2o: real
        ! selfrefo: real
        ! forrefo : real
        !-----------------------------------------------------------------
        !-----------------------------------------------------------------
        ! rrtmg_lw COMBINED abs. coefficients for interval 3
        ! band 3:  500-630 cm-1 (low - h2o,co2; high - h2o,co2)
        !
        ! Initial version:  JJMorcrette, ECMWF, jul1998
        ! Revised: MJIacono, AER, jun2006
        !-----------------------------------------------------------------
        !
        !  name     type     purpose
        !  ----   : ----   : ---------------------------------------------
        !fracrefa : real
        !fracrefb : real
        ! ka      : real
        ! kb      : real
        ! ka_mn2o : real
        ! kb_mn2o : real
        ! selfref : real
        ! forref  : real
        !
        ! absa    : real
        ! absb    : real
        !-----------------------------------------------------------------
        INTEGER, parameter :: ng3  = 16
        REAL(KIND=r8) :: fracrefa(ng3,10)
        REAL(KIND=r8) :: fracrefb(ng3,5)
        REAL(KIND=r8) :: absa(585,ng3)
        REAL(KIND=r8) :: absb(1175,ng3)
        REAL(KIND=r8) :: ka_mn2o(9,19,ng3)
        REAL(KIND=r8) :: kb_mn2o(5,19,ng3)
        REAL(KIND=r8) :: selfref(10,ng3)
        REAL(KIND=r8) :: forref(4,ng3)
        PUBLIC kgen_read_externs_rrlw_kg03
    CONTAINS

    ! write subroutines

    ! module extern variables

    SUBROUTINE kgen_read_externs_rrlw_kg03(kgen_unit)
        INTEGER, INTENT(IN) :: kgen_unit
        READ(UNIT=kgen_unit) fracrefa
        READ(UNIT=kgen_unit) fracrefb
        READ(UNIT=kgen_unit) absa
        READ(UNIT=kgen_unit) absb
        READ(UNIT=kgen_unit) ka_mn2o
        READ(UNIT=kgen_unit) kb_mn2o
        READ(UNIT=kgen_unit) selfref
        READ(UNIT=kgen_unit) forref
    END SUBROUTINE kgen_read_externs_rrlw_kg03

    END MODULE rrlw_kg03


!===== MAKING SCD file from FMP file =====

program mkscd

use prm_var

use mod_ctpinv
use mod_setinv

use mod_dissou

implicit none

integer :: nsource, icm, igsi, i, ll
real(8) :: glat(3000), glon(3000)
character(len=24) :: flobspd, cal, fmp, hd, fctp = "                        "
character(len=6) :: cstation(3000)

open(77,file="../tmp/mkscd.out")

call getarg(1,fctp)

open(9,file=fctp)
CALL SETCP(hd,flobspd,cal,fmp,nsource)

open(33,file=fdum,status='old')
	CALL INPUTD(33)
close(33)

CALL SETUP(fdum,nsource,icm,1)

if(nsource /= 1) stop 'nsource /= 1: this program cannnot make multi-source!'

open(22,file=fmp)
CALL MKFMP(22)
close(22)

open(22,file=fmp)
CALL RDFMP(22)
close(22)

CALL DISSOU(hd,nsource)

print *, " -------------------------------------------"
print *, " SET GSI GPS POSITION"
print *, "  LATI min-max: ", int(glatmin), int(glatmax)
print *, "  LONG min-max: ", int(glonmin), int(glonmax)

open(98,file=fgps)
open(99,file=fpos)

read(98,*) igsi

ll = 1

do i = 1, igsi
	read(98,'(F11.7,1X,F11.8,1X,A6)') glon(ll), glat(ll), cstation(ll)
	if(glon(ll) < glonmin .or. glon(ll) > glonmax) cycle
	if(glat(ll) < glatmin .or. glat(ll) > glatmax) cycle
	ll = ll + 1
end do

write(99,*) 2*(ll-1), ll-1, ll-1, 0

do i = 1, ll-1
	write(99,'(I7,1X,F12.5,1X,F12.5,4X,A6)') i, glat(i), glon(i), cstation(i)
end do

do i = 1, ll-1
	write(99,'(I7,1X,F12.5,1X,F12.5,4X,A6)') i+(ll-1), glat(i), glon(i), cstation(i)
end do

close(98)
close(99)

close(77)
close(9)

stop

contains
!==========
subroutine RDFMP(ifn)

	use prm_matrix
	use prm_inv
	use prm_var

	implicit none

	integer, intent(in) :: ifn
	integer :: n, m, is, it, n1, n2, n3, iso, is1, it1

	n = 1

	read(ifn,*)
	read(ifn,*) n1, n2, n3
	print *, "KS KT DEG", n1, n2, n3
	read(ifn,*)

	do m = 1, 2
		do it = 1, n2
			do is = 1, n1
				read(ifn,*) iso, is1, it1, x(n), cs(n,n)
				if(is1 /= is) stop "is"
				if(it1 /= it) stop "it"
				if(iso > 4) stop "iso"
				n = n + 1
			end do
		end do
	end do

return
end subroutine RDFMP

!==========
subroutine MKFMP(ifn)

	use prm_inv

	implicit none

	integer, intent(in) :: ifn
	integer :: m, is, it, n1, n2, n3, iss, itt
	real(8) :: xconst1, xconst2, const

	n1 = js0(1)
	n2 = jt0(1)
	n3 = ndgs(1)
	xconst1 = 0.002d0
	xconst2 = 0.2d0

	write(ifn,*) "KS KT DEG"
	write(ifn,*) n1, n2, n3
	write(ifn,*) " SOURCE    IS    IT         M.P.         E.E. "

	m = 1

	open(97,file="./init.dat")
	read(97,*)

	do it = 1, n2
		do is = 1, n1
			read(97,*) itt, iss, const
			if(itt/=it .or. iss/=is) stop "it or is error in init.dat"
			write(ifn,'(3I4,2F10.3)') m, is, it, 0.d0, 0.d0
		end do
	end do

	close(96)

	m = 2

	open(97,file="./init.dat")
	read(97,*)

	do it = 1, n2
		do is = 1, n1
			read(97,*) itt, iss, const
			if(itt/=it .or. iss/=is) stop "it or is error in init.dat"
			write(ifn,'(3I4,2F10.3)') m, is, it, -const, 0.d0
		end do
	end do

	close(97)

	write(ifn,*) "end"

return
end subroutine MKFMP

!==========

end


module sirMod
use iso_c_binding, only: c_int, c_float, c_double, c_char

implicit none

integer, parameter :: kt=400      !maximum number of depth points (64)
integer, parameter :: kn=400      !maximum number of nodes (64)
integer, parameter :: kl=10       !maximum number of lines (100)
integer, parameter :: kld=5000    !maximum number of wavelengths (600)
integer, parameter :: mfitmax=200 !maximum number of total nodes (200)
integer, parameter :: kld4=4*kld, kldt=kld*kn, kldt4=4*kldt, kt8=8*kt+2, kl4=4*kl

type configuration
	integer ntl,nlin(kl),npas(kl),nble(kl)
	real*4 dlamda(kld)
	integer ntls,nlins(kl4),npass(kl4)
	real*4 dlamdas(kld4)
	real*4 abu(92)

	character*2 atom_all(kl)
	integer istage_all(kl)
    real*4 wlengt_all(kl)
    real*4 zeff_all(kl)
	real*4 energy_all(kl)
	real*4 loggf_all(kl)
	integer mult_all(2,kl)
	character*1 design_all(2,kl)
	real*4 tam_all(2,kl)
	real*4 alfa_all(kl)
	real*4 sigma_all(kl)

end type configuration

type(configuration) :: conf(10)

contains

	subroutine c_init_externalfile(index, nchar, file_lines, nLambda) bind(c)
	integer(c_int), intent(in) :: index, nchar
	character(c_char), intent(in) :: file_lines(nchar)
	integer(c_int), intent(out) :: nLambda

	integer :: i, j, ifiltro
	integer ntl,nlin(kl),npas(kl),nble(kl)
	real*4 dlamda(kld)
	integer ntls,nlins(kl4),npass(kl4)
	real*4 dlamdas(kld4), eps(92)
	character*2 atom
	integer istage
	real*4 wlengt
	real*4 zeff
	real*4 energy
	real*4 loggf
	integer mult(2)
	character*1 design(2)
	real*4 tam(2)
	real*4 alfa
	real*4 sigma

	integer :: ixx, iln, ible, nxx

	common/Malla/ntl,nlin,npas,nble,dlamda
    common/Malla4/ntls,nlins,npass,dlamdas  !common para StokesFRsub
	common/ifiltro/ifiltro
	common/abundances/eps

		call leyendo

		!call lee_all_lines

! contamos el numero de puntos
		nLambda = 0
		do i=1,ntl
        	do j=1,npas(i)
	      		nLambda = nLambda + 1
	    	end do
		end do

		ifiltro = 0

		conf(index)%ntl = ntl
		conf(index)%nlin = nlin
		conf(index)%npas = npas
		conf(index)%nble = nble
		conf(index)%dlamda = dlamda
		conf(index)%ntls = ntls
		conf(index)%nlins = nlins
		conf(index)%npass = npass
		conf(index)%dlamdas = dlamdas

		conf(index)%abu = eps

		print *, 'ntl ', ntl
		print *, 'nlin ', nlin
		print *, 'npas ', npas
		print *, 'nble ', nble
		print *, 'dlamda ', dlamda(1:npas(1))
		print *, 'ntls ', ntls
		print *, 'nlins ', nlins
		print *, 'npass ', npass
		print *, 'dlamdas ', dlamdas

        ixx=0
        do iln=1,ntl
           do ible=1,nble(iln)
             ixx=ixx+1
             nxx=nlin(ixx)
             if(nxx.eq.0)then
                nxx=nlin(ixx-1)
                call leelineasii(file_lines(1:nchar),nxx,atom,istage,wlengt,zeff,energy,loggf,mult,design,tam,alfa,sigma)
                loggf=-20.
                wlengt=5000.
             else
                call leelineasii(file_lines(1:nchar),nxx,atom,istage,wlengt,zeff,energy,loggf,mult,design,tam,alfa,sigma)
             endif

             conf(index)%atom_all(ixx)=atom
             conf(index)%istage_all(ixx)=istage
             conf(index)%wlengt_all(ixx)=wlengt
             conf(index)%zeff_all(ixx)=zeff
             conf(index)%energy_all(ixx)=energy
             conf(index)%loggf_all(ixx)=loggf
             conf(index)%mult_all(1,ixx)=mult(1)
             conf(index)%mult_all(2,ixx)=mult(2)
             conf(index)%design_all(1,ixx)=design(1)
             conf(index)%design_all(2,ixx)=design(2)
             conf(index)%tam_all(1,ixx)=tam(1)
             conf(index)%tam_all(2,ixx)=tam(2)
             conf(index)%alfa_all(ixx)=alfa
             conf(index)%sigma_all(ixx)=sigma

			 print *, iln, ible
			 print *, 'atom ', atom
			 print *, 'istage ', istage
			 print *, 'wlengt ', wlengt
			 print *, 'zeff ', zeff
			 print *, 'energy ', energy
			 print *, 'loggf ', loggf
			 print *, 'mult1 ', mult(1)
			 print *, 'mult2 ', mult(2)
			 print *, 'design1 ', design(1)
			 print *, 'design2 ', design(2)
			 print *, 'tam1 ', tam(1)
			 print *, 'tam2 ', tam(2)
			 print *, 'alfa ', alfa
			 print *, 'sigma ', sigma

           enddo
        enddo

	end subroutine c_init_externalfile

	subroutine c_init(index, n_blend, lines_in, atom_in, istage_in, wlength_in, zeff_in, energy_in, loggf_in, mult1_in, mult2_in, &
		design1_in, design2_in, tam1_in, tam2_in, alfa_in, sigma_in, lambda0_in, lambda1_in, n_steps_in) bind(c)
	integer(c_int), intent(in) :: index, n_blend
	integer(c_int), intent(in) :: atom_in(n_blend), istage_in(n_blend), lines_in(n_blend)
	integer(c_int), intent(in) :: mult1_in(n_blend), mult2_in(n_blend), design1_in(n_blend), design2_in(n_blend)
	real(c_double), intent(in) :: zeff_in(n_blend), energy_in(n_blend), loggf_in(n_blend), wlength_in(n_blend)
	real(c_double), intent(in) :: tam1_in(n_blend), tam2_in(n_blend), alfa_in(n_blend), sigma_in(n_blend)
	integer(c_int), intent(in) :: n_steps_in
	real(c_double), intent(in) :: lambda0_in, lambda1_in

	integer :: i, j, k, ifiltro
	integer ntl,nlin(kl),npas(kl),nble(kl)
	real*4 dlamda(kld)
	integer ntls,nlins(kl4),npass(kl4)
	real*4 dlamdas(kld4)
	character*2 atom
	integer istage
	real*4 wlengt
	real*4 zeff
	real*4 energy
	real*4 loggf
	integer mult(2)
	character*1 design(2)
	real*4 tam(2)
	real*4 alfa
	real*4 sigma
	real*4 lstep

	character(len=1), dimension(6) :: state = (/'S', 'P', 'D', 'F', 'G', 'H'/)

	character(len=2), dimension(92) :: atom_name = (/'H ','HE','LI','BE','B ','C ','N ','O ','F ','NE',&
     'NA','MG','AL','SI','P ','S ','CL','AR','K ','CA','SC','TI','V ','CR',&
     'MN','FE','CO','NI','CU','ZN','GA','GE','AS','SE','BR','KR',&
     'RB','SR','Y ','ZR','NB','MO','TC','RU','RH','PD','AG','CD','IN',&
     'SN','SB','TE','I ','XE','CS','BA','LA','CE','PR','ND','PM',&
     'SM','EU','GD','TB','DY','HO','ER','TM','YB','LU','HF','TA','W ',&
     'RE','OS','IR','PT','AU','HG','TL','PB','BI','PO','AT','RN',&
     'FR','RA','AC','TH','PA','U '/)

	! ASPLUND (2009)
	real(kind=4), dimension(92) :: eps = (/12.00,10.93,1.05,1.38,2.70,8.43,7.83,8.69,4.56 ,7.93 ,6.24 ,7.60 ,6.45 ,7.51 ,5.41 ,7.12 ,5.50 ,6.40 ,5.03 ,&
		6.34 ,3.15 ,4.95 ,3.93 ,5.64 ,5.43 ,7.50 ,4.99 ,6.22 ,4.19 ,4.56 ,3.04 ,3.65 ,2.30 ,3.34 ,2.54 ,3.25 ,2.52 ,&
		2.87 ,2.21 ,2.58 ,1.46 ,1.88 ,0.00 ,1.75,0.91 ,1.57,0.94 ,1.71 ,0.80 ,2.04 ,1.01 ,2.18 ,1.55 ,2.24 ,1.08 ,&
		2.18 ,1.10 ,1.58 ,0.72 ,1.42 ,0.00 ,0.92 ,0.52 ,1.07 ,0.30 ,1.10 ,0.48 ,0.92 ,0.10 ,0.84 ,0.10 ,0.85 ,-0.12 ,&
		0.85 ,0.26 ,1.40 ,1.38 ,1.62 ,0.92 ,1.17 ,0.90 ,1.75 ,0.65 ,-8.0 ,-8.0 ,-8.0 ,-8.0 ,-8.0 ,-8.0 ,0.02 ,-8.0 ,-0.54/)

	integer :: ixx, iln, ible, nxx

	common/Malla/ntl,nlin,npas,nble,dlamda
    common/Malla4/ntls,nlins,npass,dlamdas  !common para StokesFRsub
	common/ifiltro/ifiltro
	common/abundances/eps

		ntl = 1
		ntls = 4
		npas(1) = n_steps_in
		nble(1) = n_blend

		lstep = (lambda1_in - lambda0_in) / (n_steps_in - 1.0)

		do i = 0, n_steps_in-1
			dlamda(i+1) = lambda0_in + lstep * i
		enddo

		do i = 1, n_blend
			nlin(i) = lines_in(i)
		enddo

		k = 1
		do j = 1, 4
			do i = 1, n_blend
				nlins(k) = nlin(i)
				k = k + 1
			enddo
		enddo

		do j = 1, 4
			npass(j) = npas(1)
		enddo

		k = 1
		do j = 1, 4
			do i = 1, npas(1)
				dlamdas(k) = dlamda(i)
				k = k + 1
			enddo
		enddo

		conf(index)%ntl = ntl
		conf(index)%nlin = nlin
		conf(index)%npas = npas
		conf(index)%nble = nble
		conf(index)%dlamda = dlamda
		conf(index)%ntls = ntls
		conf(index)%nlins = nlins
		conf(index)%npass = npass
		conf(index)%dlamdas = dlamdas
		conf(index)%abu = eps

		ifiltro = 0

		do ixx = 1, n_blend
			conf(index)%atom_all(ixx)=atom_name(atom_in(ixx))
			conf(index)%istage_all(ixx)=istage_in(ixx)
			conf(index)%wlengt_all(ixx)=wlength_in(ixx)
			conf(index)%zeff_all(ixx)=zeff_in(ixx)
			conf(index)%energy_all(ixx)=energy_in(ixx)
			conf(index)%loggf_all(ixx)=loggf_in(ixx)
			conf(index)%mult_all(1,ixx)=mult1_in(ixx)
			conf(index)%mult_all(2,ixx)=mult2_in(ixx)
			conf(index)%design_all(1,ixx)=state(design1_in(ixx)+1)
			conf(index)%design_all(2,ixx)=state(design2_in(ixx)+1)
			conf(index)%tam_all(1,ixx)=tam1_in(ixx)
			conf(index)%tam_all(2,ixx)=tam2_in(ixx)
			conf(index)%alfa_all(ixx)=alfa_in(ixx)
			conf(index)%sigma_all(ixx)=sigma_in(ixx)

		enddo

	end subroutine c_init

	subroutine c_setpsf(nPSF, xPSF, yPSF) bind(c)
	integer(c_int), intent(in) :: nPSF
	real(c_float), intent(in) :: xPSF(nPSF), yPSF(nPSF)
	integer :: i, j
	integer, parameter :: nmx=401
	real*4 x(nmx), y(nmx)
	character*100 filtro
	integer ifiltro, num
	common/filtro/filtro,x,y,num                 !para pasar el nombre de la PSF
    common/ifiltro/ifiltro

		ifiltro = 1
    	do i = 1, nPSF
    		x(i) = xPSF(i)
    		y(i) = yPSF(i)
    	enddo
    	num = nPSF

	end subroutine c_setpsf

	subroutine c_synth(index, nDepth, nLambda, macroturbulence, model, stokes, colmass, error) bind(c)
	integer(c_int), intent(in) :: index, nDepth, nLambda
	real(c_double), intent(in) :: model(8,ndepth)
	real(c_double), intent(in) :: macroturbulence
	real(c_double), intent(out) :: stokes(5,nLambda), colmass(ndepth)
	integer(c_int), intent(out) :: error

	real*4 stok(kld4)
    real*4 rt(kldt4),rp(kldt4),rh(kldt4),rv(kldt4)
    real*4 rg(kldt4),rf(kldt4),rm(kldt4), rmac(kld4)
    integer ist(4),i,k,ntot, j, l, itau
	character*100 Stokesfilename
	integer*4 mnodos(18), ntau
	real*4 atmosmodel(kt8), pesostray
	real*4 tau(kt), t(kt), pe(kt), pg(kt), z(kt), ro(kt), cmass(kt), dLPgdT(kt), dLPgdPe(kt)
	real*4 voffset,xmu

	integer ntl,nlin(kl),npas(kl),nble(kl)
	real*4 dlamda(kld)
	integer ntls,nlins(kl4),npass(kl4)
	real*4 dlamdas(kld4)
	real*4 beta1(kl,kt),beta2(kl,kt)

	character*2 atom_all(kl)
	integer istage_all(kl)
    real*4 wlengt_all(kl)
    real*4 zeff_all(kl)
	real*4 energy_all(kl)
	real*4 loggf_all(kl)
	integer mult_all(2,kl)
	character*1 design_all(2,kl)
	real*4 tam_all(2,kl)
	real*4 alfa_all(kl)
	real*4 sigma_all(kl)

	integer :: ixx, ible

	integer :: error_code
	common/Error/error_code

    common/OutputStokes/Stokesfilename

    common/Atmosmodel/atmosmodel,ntau !common para StokesFRsub
	common/numeronodos/mnodos         !para StokesFRsub
    common/offset/voffset             !para StokesFRsub
    common/anguloheliocent/xmu        !para StokesFRsub
	common/departcoef/beta1,beta2

	common/Malla/ntl,nlin,npas,nble,dlamda  !common para StokesFRsub
    common/Malla4/ntls,nlins,npass,dlamdas  !common para StokesFRsub
	common/Lineas_all/atom_all,istage_all,wlengt_all,zeff_all,energy_all,loggf_all,mult_all,design_all,tam_all,alfa_all,sigma_all

		atmosmodel = 0
		error = 0
		error_code = 0

		ntl = conf(index)%ntl
		nlin = conf(index)%nlin
		npas = conf(index)%npas
		nble = conf(index)%nble
		dlamda = conf(index)%dlamda
		ntls = conf(index)%ntls
		nlins = conf(index)%nlins
		npass = conf(index)%npass
		dlamdas = conf(index)%dlamdas

		atom_all = conf(index)%atom_all
		istage_all = conf(index)%istage_all
		wlengt_all = conf(index)%wlengt_all
		zeff_all = conf(index)%zeff_all
		energy_all = conf(index)%energy_all
		loggf_all = conf(index)%loggf_all
		mult_all = conf(index)%mult_all
		design_all = conf(index)%design_all
		tam_all = conf(index)%tam_all
		alfa_all = conf(index)%alfa_all
		sigma_all = conf(index)%sigma_all

	    ntau = nDepth

! offset de velocidad para perturbaciones relativas necesitamos que la velocidad sea siempre positiva
		voffset=-15.e5    !cm/s
	    xmu=1.            !coseno del angulo heliocentrico

! Put the model in vectorized form
		atmosmodel(8*ntau+1) = macroturbulence
		atmosmodel(8*ntau+2) = 1.0   ! filling
		pesostray = 1.0              ! stray
		do i = 1, ntau
			do j = 0, 7
				atmosmodel(i+j*ntau) = model(j+1,i)
			enddo
			tau(i) = atmosmodel(i)
			t(i) = atmosmodel(i+ntau)
			pe(i) = atmosmodel(i+2*ntau)
		enddo

! pasamos los angulos a radianes
		call taulinea(0,1.,1,0.,atmosmodel,ntau)

! definimos los nodos en todos los puntos (excepto para ls presion elctronica)
		do i=1,8
        	mnodos(i)=ntau
		end do
    	! mnodos(2)=0

! Compute hydrostatic equilibrium if necessary
		if (minval(model(3,:)) == -1) then
			call equisubmu(ntau,tau,t,pe,pg,z,ro,cmass)

			if (error_code == 1) then
				error = 1
				return
			endif

        	do i=1,ntau
            	atmosmodel(i+2*ntau)=pe(i)
        	end do
        endif

! Set the departure coefficients
		ixx=0
        do l=1,ntl
	   		do ible=1,nble(l)
	   			ixx=ixx+1
              		do i=1,ntau
                 		beta1(ixx,i)=1.0 !departure(1, ixx, i)  !entran ordenados sobre todas lineas*blends
                 		beta2(ixx,i)=1.0 !departure(2, ixx, i)
	      			end do
           	end do
        end do

		call StokesFRsub(stok,rt,rp,rh,rv,rg,rf,rm,rmac,dLPgdPe,dLPgdT)

		if (error_code == 1) then
			error = 1
			return
		endif

! contamos el numero de puntos
		ntot=0
		do i=1,ntl
        	do j=1,npas(i)
	      		ntot=ntot+1
	    	end do
		end do

! Output Stokes parameters
		stokes(1,:) = dlamda(1:ntot)
		stokes(2,:) = stok(1:ntot)
		stokes(3,:) = stok(ntot+1:2*ntot)
		stokes(4,:) = stok(2*ntot+1:3*ntot)
		stokes(5,:) = stok(3*ntot+1:4*ntot)

! Column mass
		colmass(:) = cmass(1:ntau)

	end subroutine c_synth

	subroutine c_synthrf(index, nDepth, nLambda, nLines, macroturbulence, model, departure, stokes, colmass, RFt, RFp, RFh, RFv, RFg, RFf, RFmic, RFmac, error) bind(c)
	integer(c_int), intent(in) :: index, nDepth, nLambda, nLines
	real(c_double), intent(in) :: model(8,ndepth), departure(2, nLines, nDepth)
	real(c_double), intent(in) :: macroturbulence
	real(c_double), intent(out) :: stokes(5,nLambda), colmass(ndepth)
	real(c_double), intent(out), dimension(4,nLambda,nDepth) :: RFt, RFp, RFh, RFv, RFg, RFf, RFmic
	real(c_double), intent(out), dimension(4,nLambda) :: RFmac
	integer(c_int), intent(out) :: error

	real*4 stok(kld4)
    real*4 rt(kldt4),rp(kldt4),rh(kldt4),rv(kldt4)
    real*4 rg(kldt4),rf(kldt4),rm(kldt4), rmac(kld4)
    integer ist(4),i,k,ntot, j, l, itau
	character*100 Stokesfilename
	integer*4 mnodos(18), ntau
	real*4 tau(kt),t(kt),pe(kt),pg(kt),z(kt),ro(kt), cmass(kt), t2(kt), pe2(kt), dPedT(kt,kt), dLPgdT(kt), dLPgdPe(kt), dPedT2(kt,kt), caca(kt)
	real*4 atmosmodel(kt8), pesostray
	real*4 voffset,xmu

	integer ntl,nlin(kl),npas(kl),nble(kl)
	real*4 dlamda(kld)
	integer ntls,nlins(kl4),npass(kl4)
	real*4 dlamdas(kld4)

	character*2 atom_all(kl)
	integer istage_all(kl)
    real*4 wlengt_all(kl)
    real*4 zeff_all(kl)
	real*4 energy_all(kl)
	real*4 loggf_all(kl)
	integer mult_all(2,kl)
	character*1 design_all(2,kl)
	real*4 tam_all(2,kl)
	real*4 alfa_all(kl)
	real*4 sigma_all(kl)
	real*4 beta1(kl,kt),beta2(kl,kt)

	integer :: ixx, ible

	integer :: error_code
	common/Error/error_code

    common/OutputStokes/Stokesfilename

    common/Atmosmodel/atmosmodel,ntau !common para StokesFRsub
	common/numeronodos/mnodos         !para StokesFRsub
    common/offset/voffset             !para StokesFRsub
    common/anguloheliocent/xmu        !para StokesFRsub
	common/departcoef/beta1,beta2

	common/Malla/ntl,nlin,npas,nble,dlamda  !common para StokesFRsub
	common/Malla4/ntls,nlins,npass,dlamdas  !common para StokesFRsub
	common/Lineas_all/atom_all,istage_all,wlengt_all,zeff_all,energy_all,loggf_all,mult_all,design_all,tam_all,alfa_all,sigma_all

		atmosmodel = 0
		error = 0
		error_code = 0

		error_code = 0

		ntl = conf(index)%ntl
		nlin = conf(index)%nlin
		npas = conf(index)%npas
		nble = conf(index)%nble
		dlamda = conf(index)%dlamda
		ntls = conf(index)%ntls
		nlins = conf(index)%nlins
		npass = conf(index)%npass
		dlamdas = conf(index)%dlamdas

		atom_all = conf(index)%atom_all
		istage_all = conf(index)%istage_all
		wlengt_all = conf(index)%wlengt_all
		zeff_all = conf(index)%zeff_all
		energy_all = conf(index)%energy_all
		loggf_all = conf(index)%loggf_all
		mult_all = conf(index)%mult_all
		design_all = conf(index)%design_all
		tam_all = conf(index)%tam_all
		alfa_all = conf(index)%alfa_all
		sigma_all = conf(index)%sigma_all

	    ntau = nDepth

! offset de velocidad para perturbaciones relativas necesitamos que la velocidad sea siempre positiva
		voffset=-15.e5    !cm/s
	    xmu=1.            !coseno del angulo heliocentrico

! Put the model in vectorized form
		atmosmodel(8*ntau+1) = macroturbulence
		atmosmodel(8*ntau+2) = 1.0 ! Filling
		pesostray = 1.0            ! stray
		do i = 1, ntau
			do j = 0, 7
				atmosmodel(i+j*ntau) = model(j+1,i)
			enddo
			tau(i) = atmosmodel(i)
			t(i) = atmosmodel(i+ntau)
			pe(i) = atmosmodel(i+2*ntau)
		enddo

! pasamos los angulos a radianes
		call taulinea(0,1.,1,0.,atmosmodel,ntau)

! definimos los nodos en todos los puntos (excepto para ls presion elctronica)
		do i=1,8
        	mnodos(i)=ntau
		end do

		! Since mnodos(2) is not zero, the RF(T) will not be corrected by the RF(Pe) because
		! of the hydrostatic equilibrium
		! mnodos(2)=0

		!NUMERICAL CALCULATION OF dPe/dT
		! call equisubmu(ntau,tau,t,pe,pg,z,ro,caca)

		! do j = 1, ntau
		! 	do i = 1, ntau
		! 		t2(i) = atmosmodel(i+ntau)
		! 		pe2(i) = atmosmodel(i+2*ntau)
		! 	enddo

		! 	t2(j) = t2(j) + 0.1d0
		! 	call equisubmu(ntau,tau,t2,pe2,pg,z,ro,caca)
		! 	if (error_code == 1) then
		! 		error = 1
		! 		return
		! 	endif

		! 	do i = 1, ntau
		! 		dPedT2(j,i) = (pe2(i) - pe(i)) / 0.1d0
		! 	enddo

		! enddo

! Calculate hydrostatic equilibrium if Pe is not known
		if (minval(model(3,:)) == -1) then
			call equisubmu(ntau,tau,t,pe,pg,z,ro,cmass)
			if (error_code == 1) then
				error = 1
				return
			endif
		endif

        do i=1,ntau
			atmosmodel(i+2*ntau)=pe(i)
        end do

! Set the departure coefficients
		ixx=0
        do l=1,ntl
	   		do ible=1,nble(l)
	   			ixx=ixx+1
              		do i=1,ntau
                 		beta1(ixx,i)=departure(1, ixx, i)  !entran ordenados sobre todas lineas*blends
                 		beta2(ixx,i)=departure(2, ixx, i)
	      			end do
           	end do
        end do

		dPedT = 0.d0
		call StokesFRsub(stok,rt,rp,rh,rv,rg,rf,rm,rmac,dLPgdPe,dLPgdT)

		do i = 1, ntau
			dPedT(i, i) = -dLPgdT(i) / dLPgdPe(i)
		enddo

		if (error_code == 1) then
			error = 1
			return
		endif

! contamos el numero de puntos
		ntot=0
		do i=1,ntl
        	do j=1,npas(i)
	      		ntot=ntot+1
	    	end do
		end do

! Output Stokes parameters
		stokes(1,:) = dlamda(1:ntot)
		stokes(2,:) = stok(1:ntot)
		stokes(3,:) = stok(ntot+1:2*ntot)
		stokes(4,:) = stok(2*ntot+1:3*ntot)
		stokes(5,:) = stok(3*ntot+1:4*ntot)

! Output response functions
		do itau = 1, ntau
			RFt(1,:,itau) = rt(1+4*ntot*(itau-1):ntot+4*ntot*(itau-1))
			RFt(2,:,itau) = rt(ntot+1+4*ntot*(itau-1):2*ntot+4*ntot*(itau-1))
			RFt(3,:,itau) = rt(2*ntot+1+4*ntot*(itau-1):3*ntot+4*ntot*(itau-1))
			RFt(4,:,itau) = rt(3*ntot+1+4*ntot*(itau-1):4*ntot+4*ntot*(itau-1))

			RFp(1,:,itau) = rp(1+4*ntot*(itau-1):ntot+4*ntot*(itau-1))
			RFp(2,:,itau) = rp(ntot+1+4*ntot*(itau-1):2*ntot+4*ntot*(itau-1))
			RFp(3,:,itau) = rp(2*ntot+1+4*ntot*(itau-1):3*ntot+4*ntot*(itau-1))
			RFp(4,:,itau) = rp(3*ntot+1+4*ntot*(itau-1):4*ntot+4*ntot*(itau-1))

			RFh(1,:,itau) = rh(1+4*ntot*(itau-1):ntot+4*ntot*(itau-1))
			RFh(2,:,itau) = rh(ntot+1+4*ntot*(itau-1):2*ntot+4*ntot*(itau-1))
			RFh(3,:,itau) = rh(2*ntot+1+4*ntot*(itau-1):3*ntot+4*ntot*(itau-1))
			RFh(4,:,itau) = rh(3*ntot+1+4*ntot*(itau-1):4*ntot+4*ntot*(itau-1))

			RFv(1,:,itau) = rv(1+4*ntot*(itau-1):ntot+4*ntot*(itau-1))
			RFv(2,:,itau) = rv(ntot+1+4*ntot*(itau-1):2*ntot+4*ntot*(itau-1))
			RFv(3,:,itau) = rv(2*ntot+1+4*ntot*(itau-1):3*ntot+4*ntot*(itau-1))
			RFv(4,:,itau) = rv(3*ntot+1+4*ntot*(itau-1):4*ntot+4*ntot*(itau-1))

			RFg(1,:,itau) = rg(1+4*ntot*(itau-1):ntot+4*ntot*(itau-1))
			RFg(2,:,itau) = rg(ntot+1+4*ntot*(itau-1):2*ntot+4*ntot*(itau-1))
			RFg(3,:,itau) = rg(2*ntot+1+4*ntot*(itau-1):3*ntot+4*ntot*(itau-1))
			RFg(4,:,itau) = rg(3*ntot+1+4*ntot*(itau-1):4*ntot+4*ntot*(itau-1))

			RFf(1,:,itau) = rf(1+4*ntot*(itau-1):ntot+4*ntot*(itau-1))
			RFf(2,:,itau) = rf(ntot+1+4*ntot*(itau-1):2*ntot+4*ntot*(itau-1))
			RFf(3,:,itau) = rf(2*ntot+1+4*ntot*(itau-1):3*ntot+4*ntot*(itau-1))
			RFf(4,:,itau) = rf(3*ntot+1+4*ntot*(itau-1):4*ntot+4*ntot*(itau-1))

			RFmic(1,:,itau) = rm(1+4*ntot*(itau-1):ntot+4*ntot*(itau-1))
			RFmic(2,:,itau) = rm(ntot+1+4*ntot*(itau-1):2*ntot+4*ntot*(itau-1))
			RFmic(3,:,itau) = rm(2*ntot+1+4*ntot*(itau-1):3*ntot+4*ntot*(itau-1))
			RFmic(4,:,itau) = rm(3*ntot+1+4*ntot*(itau-1):4*ntot+4*ntot*(itau-1))

		enddo

		RFmac(1,:) = rmac(1:ntot)
		RFmac(2,:) = rmac(ntot+1:2*ntot)
		RFmac(3,:) = rmac(2*ntot+1:3*ntot)
		RFmac(4,:) = rmac(3*ntot+1:4*ntot)

		do i = 1, ntot
			do j = 1, 4
				RFp(j,i,:) = matmul(dPedT(1:ntau,1:ntau), RFp(j,i,1:ntau))
			enddo
		enddo

	end subroutine c_synthrf

	subroutine c_hydroeq(nDepth, model, pe_out, error) bind(c)
	integer(c_int), intent(in) :: nDepth
	real(c_double), intent(in) :: model(8, ndepth)
	real(c_double), intent(out) :: pe_out(ndepth)
	integer(c_int), intent(out) :: error

    integer ist(4),i,k,ntot, j, l, itau
	integer*4 mnodos(18), ntau
	real*4 tau(kt),t(kt),pe(kt),pg(kt),z(kt),ro(kt), cmass(kt), pesostray
	real*4 atmosmodel(kt8)

	integer :: error_code
	common/Error/error_code

    common/Atmosmodel/atmosmodel, ntau !common para StokesFRsub

		error = 0
		error_code = 0

		ntau = nDepth

		! Put the model in vectorized form
		atmosmodel(8*ntau+1) = 0.0
		atmosmodel(8*ntau+2) = 1.0 ! Filling
		pesostray = 1.0            ! stray
		do i = 1, ntau
			do j = 0, 7
				atmosmodel(i+j*ntau) = model(j+1,i)
			enddo
			tau(i) = atmosmodel(i)
			t(i) = atmosmodel(i+ntau)
			pe(i) = atmosmodel(i+2*ntau)
		enddo

! pasamos los angulos a radianes
		call taulinea(0,1.,1,0.,atmosmodel,ntau)

! definimos los nodos en todos los puntos (excepto para ls presion elctronica)
		do i=1,8
        	mnodos(i)=ntau
		end do

! Calculate hydrostatic equilibrium if Pe is not known
		call equisubmu(ntau,tau,t,pe,pg,z,ro,cmass)
		if (error_code == 1) then
			error = 1
			return
		endif

		do i = 1, ntau
			pe_out(i) = pe(i)
		enddo

	end subroutine c_hydroeq

end module sirMod


C === RIBBON ===
C	(extracted from frodo.tlb in CCP program package)
C
      SUBROUTINE RIBBON(NRIB,RIBWID,NCHORD,OFFSET,NATOM)
C     ==================================================
C
C Generate guide points for protein ribbon, based on ideas on
C Carson & Bugg, J.Molec.Graphics 4,121-122 (1986)
C
C  Guide points for Bspline are generated along a line passing
C through each CA and along the average of the two peptide planes
C
C   NRIB     number of strands in ribbon (maximum=MAXRIB=15)
C   RIBWID   total ribbon width
C   NCHORD   number of chords/residue
C   OFFSET   amount to offset guide points away from CA positions
C   NATOM    number of atoms stored in arrays
C
      PARAMETER (MAXRIB=5,MAXRES=1500)
      PARAMETER (NOISE=0)
      DIMENSION GUIDE(4,MAXRES,MAXRIB)
      DIMENSION XCA(3,2),XO(3,2),A(3),B(3),C(3),D(3),E(3),F(3),
     .   G(3),H(3),P(3)
C
C Maximum CA-CA distance **2
      PARAMETER (DISMAX=6.**2)
C
      IF(NATOM.LE.0) THEN
	    WRITE(NOISE,1005)
1005	    FORMAT(' No atoms selected')
	    RETURN
      ENDIF
C
      IF(NRIB.GT.MAXRIB) THEN
	    WRITE(NOISE,1001) NRIB,MAXRIB
1001	    FORMAT(' Too many ribbon strands',I6,' reset to ',I6)
	    NRIB=MAXRIB
      ENDIF
C
      WRITE(NOISE,1002) NRIB,RIBWID,NCHORD,OFFSET
1002  FORMAT(' Ribbon drawn with',I4,' strands, width ',F6.2,
     . 'A'/'   Number of chords =',I3,', offset = ',F6.2,'A')
C
C Strand separation
      DRIB=0.
      IF(NRIB.GT.1) DRIB=RIBWID/(NRIB-1)
      RIB2=FLOAT(NRIB+1)/2.
C
      NAT=1
C
C Get first CA and O
1     CALL GETCAO(XCA(1,1),XO(1,1),NAT,NATOM,IERR)
CEAM  IF(NAT.LE.0) RETURN
CEAM  IF(IERR.NE.0) GO TO 1
      IF(IERR.NE.0) RETURN
      I=0
C
C  Loop for residues
10    I=I+1
C  Get CA and O for residue I+1
      CALL GETCAO(XCA(1,2),XO(1,2),NAT,NATOM,IERR)
C Set LEND = 1 for end of chain under 3 conditions:
C  (a) all atoms done; (b) one fo CA or O missing; (c) break in chain
      IF(NAT.LT.0.OR.IERR.NE.0) THEN
	    LEND=1
      ELSE
	    LEND=0
      ENDIF
C
      IF(LEND.EQ.0) THEN
C Not last one unless CA-CA distance too large
C   A is vector CAi to Ci+1
	    CALL VDIF(A,XCA(1,2),XCA(1,1))
	    IF(DOT(A,A).GT.DISMAX) LEND=1
      ENDIF
      IF(LEND.EQ.0) THEN
C Not last one
C   B is vector CAi to Oi
	    CALL VDIF(B,XO(1,1),XCA(1,1))
C   C = A x B;  D = C x A
	    CALL CROSS(A,B,C)
	    CALL CROSS(C,A,D)
	    CALL UNIT(D)
C
	    IF(I.EQ.1) THEN
C  First peptide, no previous one to average with
		  CALL VSET(E,D)
C  No offset for first CA
		  CALL ZEROI(P,3)
	    ELSE
C  Not first, ribbon cross vector is average of peptide plane
C  with previous one
		  CALL SCALEV(B,SIGN(1.,DOT(D,G)),D)
		  CALL VSUM(E,G,B)
C  Offset is along bisector of CA-CA-CA vectors A (H is Ai-1)
		  CALL VDIF(P,H,A)
		  CALL UNIT(P)
	    ENDIF
      ELSE
C  Last one, just use last plane
	    CALL VSET(E,G)
C  No offset for last CA
	    CALL ZEROI(P,3)
      ENDIF
C Normalise vector E
      CALL UNIT(E)
C      WRITE(NOISE,1003) I,G,D,B,E
C1003  FORMAT(' I,G,D,B,E',I4,4(3X,3F8.2)/)
C
C
C Generate guide points
      CALL SCALEV(P,OFFSET,P)
      CALL VSUM(P,XCA(1,1),P)
C
      DO 20,J=1,NRIB
      FR=(FLOAT(J)-RIB2)*DRIB
      CALL SCALEV(F,FR,E)
      CALL VSUM(GUIDE(1,I,J),P,F)
C     EAM - Maybe should be NAT-2 ??
      guide(4,i,j) = NAT - 3
20    CONTINUE
C
C Store things for next residue
      CALL VSET(XCA(1,1),XCA(1,2))
      CALL VSET(XO(1,1),XO(1,2))
      CALL VSET(G,E)
      CALL VSET(H,A)
C
      IF(LEND.EQ.0) GO TO 10
C
      NPT=I
      CALL RIBDRW(GUIDE,NRIB,MAXRES,NPT,NCHORD)
C
C Loop chains if required
CEAM  IF(NAT.GT.0) GO TO 1
      IF (IERR.EQ.0) GOTO 1
C
      RETURN
      END
C
C
      SUBROUTINE pdb_GETCAO(XCA,XO,NAT,NATOM,IERR)
C     ========================================
C
C Get coordinates of CA in XCA, O in XO,
C Modified to read sequential CA and O records in PDB format from file
C
C  On exit: NAT next atom
C           IERR  =0 if succesfull, else = 1
C
      DIMENSION XCA(3),XO(3)
C
	integer		PDBFILE
	parameter	(PDBFILE = 1)
	character*1	a1, rescode(2)
	character*3	resname(2)
	character*4	reclabel, atname
	integer		resno(2)
C
	ierr=0

	read (pdbfile,2,end=100) reclabel, nat, atname, a1, resname(1),
     1		a1, resno(1), rescode(1), xca(1), xca(2), xca(3)
	read (pdbfile,2,end=100) reclabel, nat, atname, a1, resname(2),
     1		a1, resno(2), rescode(2), xo(1), xo(2), xo(3)
    2	format(a4,2x,i5,1x,a4,a1,a3,1x,a1,i4,a1,3x,5f8.3,2f6.2,1x,i3)

	if (resname(1) .ne. resname(2)) ierr = 1
	if (resno(1)   .ne. resno(2))   ierr = 1
	if (rescode(1) .ne. rescode(2)) ierr = 1
	return

  100	continue
	ierr = 1
	nat = -1
	return

	end

      SUBROUTINE GETCAO(XCA,XO,NAT,NATOM,IERR)
C     ========================================
C
C Get coordinates of CA in XCA, O in XO,
C modified to get coords from common /SPAM/
C
C  On exit: NAT next atom
C           IERR  =0 if succesfull, else = 1
C
      DIMENSION XCA(3),XO(3)
C
	parameter	(MAXATOM=10000)
	common /SPAM/ natm, SPAM(4,MAXATOM), SCAM(MAXATOM)
	integer SCAM
c
	if ((nat .gt. natm) .or. (nat .gt. natom-1)) then
	     ierr = 1
CEAM	     nat = -1
	     return
	end if

	do i=1,3
	    xca(i) = spam(i,nat)
	    xo(i)  = spam(i,nat+1)
	end do
	nat  = nat + 2
	ierr = 0
	return

	end

	subroutine zeroi( a, nwords )
	integer*4 a(nwords)
	do i = 1,nwords
	    a(i) = 0
	end do
	return
	end


      subroutine dualtx
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
C**********************************************************************
CD1
CD1 PURPOSE
CD1
CD1 To backsubstitute to get tracer solution for dual porosity nodes.
CD1
C**********************************************************************
CD2
CD2 REVISION HISTORY
CD2
CD2 Revision                    ECD
CD2 Date         Programmer     Number  Comments
CD2
CD2 10-4-93      G. Zyvoloski   N/A     Initial implementation, but
CD2                                        previous non-YMP versions
CD2                                        of FEHM exist, and the
CD2                                        current version may differ
CD2                                        from these
CD2
CD2 $Log:   /pvcs.config/fehm90/src/dualtx.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:42:56   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:03:14   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:08:48   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:23:34   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 12:00:02   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:41:06 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
CD2
CD2    Rev 1.2   Mon Jan 29 15:45:10 1996   hend
CD2 Updated Requirements Traceability
CD2
CD2    Rev 1.1   03/18/94 15:50:18   gaz
CD2 Added solve_new and cleaned up memory management.
CD2
CD2    Rev 1.0   01/20/94 10:23:36   pvcs
CD2 original version in process of being certified
CD2
C**********************************************************************
CD3
CD3 INTERFACES
CD3
CD3 Formal Calling Parameters
CD3
CD3 None
CD3
CD3 Interface Tables
CD3
CD3 None
CD3
CD3 Files
CD3
CD3 None
CD3
C**********************************************************************
CD4
CD4 GLOBAL OBJECTS
CD4
CD4 neq, bp, a21mpf, wb11, rb2mf, tb11, r3mf, a32mpf, an, npn
CD4
CD4 Global Constants
CD4
CD4 Identifier  Type     Description
CD4
CD4
CD4 Global Types
CD4
CD4 NONE
CD4
CD4 Global Variables
CD4
CD4                      COMMON
CD4 Identifier   Type    Block   Description
CD4
CD4
CD4
CD4 Global Subprograms
CD4
CD4 None
CD4
C**********************************************************************
CD5
CD5 LOCAL IDENTIFIERS
CD5
CD5 Local Constants
CD5
CD5 None
CD5
CD5 Local Types
CD5
CD5 None
CD5
CD5 Local variables
CD5
CD5 Identifier   Type        Description
CD5
CD5 id           int         Do loop index parameter over each node
CD5 idp          int         Number of first matrix node
CD5 idpp         int         Number of second matrix node
CD5 x1           real*8      Correction of current primary unknown
CD5 x2           real*8      Correction of first matrix node
CD5 x3           real*8      Correction of second matrix node
CD5
CD5 Local Subprograms
CD5
CD5 None
CD5
C**********************************************************************
CD6
CD6 FUNCTIONAL DESCRIPTION
CD6
CD6
C**********************************************************************
CD7
CD7 ASSUMPTIONS AND LIMITATIONS
CD7
CD7 None
CD7
C**********************************************************************
CD8
CD8 SPECIAL COMMENTS
CD8
CD8  Requirements from SDN: 10086-RD-2.20-00
CD8    SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
CD8    FEHM Application Version 2.20
CD8
C**********************************************************************
CD9
CD9 REQUIREMENTS TRACEABILITY
CD9
CD9 2.3.4 Solute-transport equations
CD9 2.4.7 Dual-porosity formulation
CD9
C**********************************************************************
CDA
CDA REFERENCES
CDA
CDA See FEHMN SRS, MMS, and SDD, Robinson's memo EES-4-92-354 for
CDA documentation.
CDA
C**********************************************************************
CPS
CPS PSEUDOCODE
CPS
CPS BEGIN dualtx
CPS
CPS FOR each node
CPS   Calculate indexes for matrix nodes
CPS   Calculate corrections to concentrations
CPS   Calculate concentrations
CPS ENDFOR each node
CPS
CPS END dualtx
CPS
C**********************************************************************

      use combi
      use comdi
      use comei
      use comfi
      use comgi
      use comhi
      use comdti
      use comai
      implicit none

      integer id,idp,idpp
      real*8 x1,x2,x3

      do id=1,neq
         idp=id+neq
         idpp=id+neq+neq

c     calculate node idp solution
c     x2=ab22i*(rb2-a21*x1)
c     find rt=rb2-a21*x1
c
         x1=bp(id)
         x2=wb11(id)*(rb2mf(id)-a21mpf(id)*x1)

c     calculate node idpp solution
c     x3=a33i*(r3-a32*x2)
c     find rt=r3-a32*x2
c
         x3=tb11(id)*(r3mf(id)-a32mpf(id)*x2)
c
c     update tracer varible set
c     n-r corrections

         an(idp+npn)=an(idp+npn)-x2
         an(idpp+npn)=an(idpp+npn)-x3
      enddo

      return
      end


*deck cecob
      subroutine cecob(
     & ic, ica, icb, ieqs3, is, js, ks, ls, ncc, nfct, ngw )
c
      implicit integer(a-z)
c
      integer   nunits
      parameter(nunits=4)
      integer        iunits
      common /units/ iunits(nunits)
      integer                  nlist
      equivalence ( iunits(1), nlist )
c
      integer
     & mblu,  mccu, mconu, mcu,  mcxu, mpru, nbft, nnbft,
     & mrcru, mstu, msu,   nblu, ng,   ns,   nst
      common /parmi/
     & mblu,  mccu, mconu, mcu,  mcxu, mpru, nbft, nnbft,
     & mrcru, mstu, msu,   nblu, ng,   ns,   nst
c
      common /ntgr/itl,itu,jtl,jtu,ktl,ktu,ltl,ltu,jcu,kcu,lcu,inx,
     1  jnx,knx,lnx,nwt,nwt1(3),ijsf(3),klsf(3),icxs(2,3),kcxs(2,3),
     2  npri(2,3),nprk(2,3),iesfb,kesfb,ircru,jrcru,krcru,lrcru
      dimension ica(mcu,msu,*), icb(4,24,*), nfct(*), ngw(*)
c
c     # bummer error types.
      integer   wrnerr,  nfterr,  faterr
      parameter (wrnerr=0,nfterr=1,faterr=2)
c
      go to (100,200,300,400,500,600,700,800), ieqs3
c
c  center combinations for is=js=ks=ls
c
  100 do 170 jc = 1, ic
      do 165 kc = 1, jc
      do 160 lc = 1, kc
      igw = 0
      do 140 ig = 1, ng
      ic1 = ica(ic,is,ig)
      jc1 = ica(jc,is,ig)
      kc1 = ica(kc,is,ig)
      lc1 = ica(lc,is,ig)
      if(ic1.ne.ic.and.jc1.ne.ic.and.kc1.ne.ic.and.lc1.ne.ic) go to 140
      ic2 = max(ic1,jc1)
      jc2 = min(ic1,jc1)
      kc2 = max(kc1,lc1)
      lc2 = min(kc1,lc1)
      ic3 = max(ic2,kc2)
      kc2 = min(ic2,kc2)
      lc3 = min(jc2,lc2)
      jc2 = max(jc2,lc2)
      jc3 = max(jc2,kc2)
      kc3 = min(jc2,kc2)
      do 115 icc = ncc, 1, -1
        if(jc3 - icb(2,1,icc)) 115, 105, 120
  105   if(kc3 - icb(3,1,icc)) 115, 110, 120
  110   if(lc3 - icb(4,1,icc)) 115, 145, 120
  115 continue
  120 if(jc3 .ne. jc .or. kc3 .ne. kc .or. lc3 .ne. lc) go to 140
      do 130 igw1 = igw, 1, -1
        if (ic1.eq.icb(1,igw1,ncc+1).and.
     &      jc1.eq.icb(2,igw1,ncc+1).and.
     &      kc1.eq.icb(3,igw1,ncc+1).and.
     &      lc1.eq.icb(4,igw1,ncc+1)) go to 140
  130 continue
      igw = igw + 1
      icb(1,igw,ncc+1) = ic1
      icb(2,igw,ncc+1) = jc1
      icb(3,igw,ncc+1) = kc1
      icb(4,igw,ncc+1) = lc1
  140 continue
      ncc = ncc + 1
      nfct(ncc) = ic
      ngw(ncc) = igw
      go to 150
  145 nfct(icc) = nfct(icc) + ic
  150 continue
  160 continue
  165 continue
  170 continue
      do 190  icc = 1, ncc
        jc1  = icb(2,1,icc)
        kc1  = icb(3,1,icc)
        lc1  = icb(4,1,icc)
        idc = 1
        if (jc1 .ne. ic) idc = 2
        if (kc1 .ne. jc1) idc = idc + 1
        if (lc1 .ne. kc1) idc = idc + 1
        nfct(icc) = nfct(icc)/idc
  190 continue
      go to 900
c
c  center combinations for is=js=ks>ls
c
  200 do 270 jc = 1, ic
      do 265 kc = 1, jc
      do 260 lc = 1, lcu
      igw = 0
      do 240 ig = 1, ng
      ic1 = ica(ic,is,ig)
      jc1 = ica(jc,is,ig)
      kc1 = ica(kc,is,ig)
      if(ic1.ne.ic.and.jc1.ne.ic.and.kc1.ne.ic) go to 240
      lc1 = ica(lc,ls,ig)
      ic2 = max(ic1,jc1)
      jc2 = min(ic1,jc1)
      ic3 = max(ic2,kc1)
      kc2 = min(ic2,kc1)
      jc3 = max(jc2,kc2)
      kc3 = min(jc2,kc2)
      do 215 icc = ncc, 1, -1
        if(jc3 - icb(2,1,icc)) 215, 205, 220
  205   if(kc3 - icb(3,1,icc)) 215, 210, 220
  210   if(lc1 - icb(4,1,icc)) 215, 245, 220
  215 continue
  220 if(jc3 .ne. jc .or. kc3 .ne. kc .or. lc1 .ne. lc) go to 240
      do 230 igw1 = igw, 1, -1
        if (ic1.eq.icb(1,igw1,ncc+1).and.
     &      jc1.eq.icb(2,igw1,ncc+1).and.
     &      kc1.eq.icb(3,igw1,ncc+1)) go to 240
  230 continue
      igw = igw + 1
      icb(1,igw,ncc+1) = ic1
      icb(2,igw,ncc+1) = jc1
      icb(3,igw,ncc+1) = kc1
      icb(4,igw,ncc+1) = lc1
  240 continue
      ncc = ncc + 1
      nfct(ncc) = ic
      ngw(ncc) = igw
      go to 260
  245 nfct(icc) = nfct(icc) + ic
  260 continue
  265 continue
  270 continue
      do 290 icc = 1, ncc
        jc1  = icb(2,1,icc)
        kc1  = icb(3,1,icc)
        idc = 1
        if ( jc1 .ne. ic) idc = 2
        if (kc1 .ne. jc1) idc = idc + 1
        nfct(icc) = nfct(icc)/idc
  290 continue
      go to 900
c
c  center combinations for is=js>ks=ls
c
  300 do 370 jc = 1, ic
      do 365 kc = 1, kcu
      do 360 lc = 1, kc
      igw = 0
      do 340 ig = 1, ng
      ic1 = ica(ic,is,ig)
      jc1 = ica(jc,is,ig)
      if(ic1.ne.ic.and.jc1.ne.ic) go to 340
      kc1 = ica(kc,ks,ig)
      lc1 = ica(lc,ks,ig)
      ic2 = max(ic1,jc1)
      jc2 = min(ic1,jc1)
      kc2 = max(kc1,lc1)
      lc2 = min(kc1,lc1)
      do 315 icc = ncc, 1, -1
        if (jc2 - icb(2,1,icc)) 315, 305, 320
  305   if (kc2 - icb(3,1,icc)) 315, 310, 320
  310   if (lc2 - icb(4,1,icc)) 315, 345, 320
  315 continue
  320 if (jc2 .ne. jc .or. kc2 .ne. kc .or. lc2 .ne. lc) go to 340
      do 330 igw1 = igw, 1, -1
        if( ic1.eq.icb(1,igw1,ncc+1).and.
     &      jc1.eq.icb(2,igw1,ncc+1).and.
     &      kc1.eq.icb(3,igw1,ncc+1).and.
     &      lc1.eq.icb(4,igw1,ncc+1)) go to 340
  330 continue
      igw = igw + 1
      icb (1,igw,ncc+1) = ic1
      icb (2,igw,ncc+1) = jc1
      icb (3,igw,ncc+1) = kc1
      icb (4,igw,ncc+1) = lc1
  340 continue
      ncc = ncc + 1
      nfct(ncc) =  ic
      ngw(ncc) = igw
      go to 360
  345 nfct(icc) = nfct(icc) + ic
  360 continue
  365 continue
  370 continue
      go to 480
c
c  center combinations for is=js>ks>ls
c
  400 do 470 jc = 1, ic
      do 465 kc = 1, kcu
      do 460 lc = 1, lcu
      igw = 0
      do 440 ig = 1, ng
      ic1 = ica(ic,is,ig)
      jc1 = ica(jc,is,ig)
      if(ic1.ne.ic.and.jc1.ne.ic) go to 440
      kc1 = ica(kc,ks,ig)
      lc1 = ica(lc,ls,ig)
      ic2 = max(ic1,jc1)
      jc2 = min(ic1,jc1)
      do 415 icc = ncc, 1, -1
        if (jc2 - icb(2,1,icc)) 415, 405, 420
  405   if (kc1 - icb(3,1,icc)) 415, 410, 420
  410   if (lc1 - icb(4,1,icc)) 415, 445, 420
  415 continue
  420 if(jc2 .ne. jc .or. kc1 .ne. kc .or. lc1 .ne. lc) go to 440
      do 430 igw1 = igw, 1, -1
        if (ic1.eq.icb(1,igw1,ncc+1).and.
     &      jc1.eq.icb(2,igw1,ncc+1)) go to 440
  430 continue
      igw = igw + 1
      icb(1,igw,ncc+1) = ic1
      icb(2,igw,ncc+1) = jc1
      icb(3,igw,ncc+1) = kc1
      icb(4,igw,ncc+1) = lc1
  440 continue
      ncc = ncc + 1
      nfct(ncc) = ic
      ngw(ncc) = igw
      go to 460
  445 nfct(icc) = nfct(icc) + ic
  460 continue
  465 continue
  470 continue
  480 do 490 icc = 1, ncc
        if(icb(2,1,icc).ne.ic) nfct(icc)=nfct(icc)/2
  490 continue
      go to 900
c
c  center combinations for is>js=ks=ls
c
  500 do 570 jc = 1, jcu
      do 565 kc = 1, jc
      do 560 lc = 1, kc
      igw =0
      do 540 ig = 1, ng
      if (ica(ic,is,ig) .ne. ic) go to 540
      jc1 = ica(jc,js,ig)
      kc1 = ica(kc,js,ig)
      lc1 = ica(lc,js,ig)
      jc2 = max (jc1,kc1)
      kc2 = min (jc1,kc1)
      jc3 = max (jc2,lc1)
      lc2 = min (jc2,lc1)
      kc3 = max (kc2,lc2)
      lc3 = min (kc2,lc2)
      do 515 icc = ncc, 1, -1
      if (jc3 - icb(2,1,icc)) 515, 505, 520
  505 if (kc3 - icb(3,1,icc)) 515, 510, 520
  510 if (lc3 - icb(4,1,icc)) 515, 545, 520
  515 continue
  520 if (jc3.ne.jc.or.kc3.ne.kc.or.lc3.ne.lc) go to 540
      do 530 igw1 = igw, 1, -1
        if (jc1.eq.icb(2,igw1,ncc+1).and.
     &      kc1.eq.icb(3,igw1,ncc+1).and.
     &      lc1.eq.icb(4,igw1,ncc+1)) go to 540
  530 continue
      igw = igw + 1
      icb (1,igw,ncc+1) = ic
      icb (2,igw,ncc+1) = jc1
      icb (3,igw,ncc+1) = kc1
      icb (4,igw,ncc+1) = lc1
  540 continue
      ncc = ncc + 1
      nfct(ncc) = ic
      ngw(ncc) = igw
      go to 560
  545 nfct(icc) = nfct(icc) + ic
  560 continue
  565 continue
  570 continue
      go to 900
c
c  center combinations for is>js=ks>ls
c
  600 do 670 jc = 1, jcu
      do 665 kc = 1, jc
      do 660 lc = 1, lcu
      igw = 0
      do 640 ig = 1, ng
      if (ica(ic,is,ig) .ne. ic) go to 640
      jc1 = ica(jc,js,ig)
      kc1 = ica(kc,js,ig)
      lc1 = ica(lc,ls,ig)
      jc2 = max (jc1, kc1)
      kc2 = min (jc1, kc1)
      do 615 icc= ncc, 1, -1
        if (jc2 - icb(2,1,icc)) 615, 605, 620
  605   if (kc2 - icb(3,1,icc)) 615, 610, 620
  610   if (lc1 - icb(4,1,icc)) 615, 645, 620
  615 continue
  620 if (jc2.ne.jc.or.kc2.ne.kc.or.lc1.ne.lc) go to 640
      do 630 igw1 = igw, 1, -1
        if (jc1.eq.icb(2,igw1,ncc+1).and.
     &      kc1.eq.icb(3,igw1,ncc+1)) go to 640
  630 continue
      igw = igw + 1
      icb (1,igw,ncc+1) = ic
      icb (2,igw,ncc+1) = jc1
      icb (3,igw,ncc+1) = kc1
      icb (4,igw,ncc+1) = lc1
  640 continue
      ncc = ncc + 1
      nfct(ncc) = ic
      ngw (ncc) = igw
      go to 660
  645 nfct(icc) = nfct(icc) + ic
  660 continue
  665 continue
  670 continue
      go to 900
c
c  center combinations for is>js>ks=ls
c
  700 do 770 jc = 1, jcu
      do 765 kc = 1, kcu
      do 760 lc = 1, kc
      igw = 0
      do 740 ig = 1, ng
      if (ica(ic,is,ig) .ne. ic) go to 740
      jc1 = ica(jc,js,ig)
      kc1 = ica(kc,ks,ig)
      lc1 = ica(lc,ks,ig)
      kc2 = max (kc1, lc1)
      lc2 = min (kc1, lc1)
      do 715 icc = ncc, 1, -1
        if (jc1 - icb(2,1,icc)) 715, 705, 720
  705   if (kc2 - icb(3,1,icc)) 715, 710, 720
  710   if (lc2 - icb(4,1,icc)) 715, 745, 720
  715 continue
  720 if (jc1.ne.jc.or.kc2.ne.kc.or.lc2.ne.lc) go to 740
      do 730 igw1 = igw, 1, -1
        if(kc1.eq.icb(3,igw1,ncc+1).and.
     &     lc1.eq.icb(4,igw1,ncc+1)) go to 740
  730 continue
      igw = igw + 1
      icb (1,igw,ncc+1) = ic
      icb (2,igw,ncc+1) = jc1
      icb (3,igw,ncc+1) = kc1
      icb (4,igw,ncc+1) = lc1
  740 continue
      ncc = ncc + 1
      nfct(ncc) = ic
      ngw(ncc) = igw
      go to 760
  745 nfct(icc) = nfct(icc) + ic
  760 continue
  765 continue
  770 continue
      go to 900
c
c  center combinations for is>js>ks>ls
c
  800 do 870 jc = 1, jcu
      do 865 kc = 1, kcu
      do 860 lc = 1, lcu
      do 840 ig = 1, ng
      if (ica(ic,is,ig) .ne. ic) go to 840
      jc1 = ica(jc,js,ig)
      kc1 = ica(kc,ks,ig)
      lc1 = ica(lc,ls,ig)
      do 815 icc = ncc, 1, -1
        if (jc1 - icb(2,1,icc)) 815, 805, 840
  805   if (kc1 - icb(3,1,icc)) 815, 810, 840
  810   if (lc1 - icb(4,1,icc)) 815, 845, 840
  815 continue
  840 continue
      ncc = ncc + 1
      icb (1, 1, ncc) = ic
      icb (2, 1, ncc) = jc
      icb (3, 1, ncc) = kc
      icb (4, 1, ncc) = lc
      nfct(ncc) = ic
      go to 860
  845 nfct(icc) = nfct(icc) + ic
  860 continue
  865 continue
  870 continue
  900 if(ncc.gt.mccu) then
        write (nlist,*) 'cecob: mccup too small', ncc
        call bummer('cecob: ncc=',ncc,faterr)
      endif
      return
      end


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     subroutine ff_eg: energies and gradients of the bonded
!            potential terms
!
!       Virial tensor components are calculated as explained in:
!       J. Comput. Chem. 23; 667-672, 2002 (Computation of Pressure Components
!       due to Class II Force Fields)
!
!     part of QMDFF
!

subroutine ff_eg(n,at,xyz,e,g)
use qmdff
use debug ! additional printout if desired
implicit none
integer::n,at(n)
real(kind=8)::xyz(3,n),e,g(3,n)

real(kind=8)::vp(3),dt,deddt,rp,cosa,rab2,rcb2,vlen,rmul1,rmul2
real(kind=8)::cosna(4),sinna(4),v(4),sa(4),ca(4),phix(4),dphi(4)
real(kind=8)::va(3),vb(3),vc(3),vd(3),vba(3),vcb(3),vdc(3),vab(3)
real(kind=8)::vca(3),vdb(3),vt(3),vu(3),vtu(3),dedt(3),dedu(3)
real(kind=8)::deda(3),dedb(3),dedc(3),dedd(3),vtmp1(3),vtmp2(3)
real(kind=8)::rt2,ru2,rtu,rcb,rtru,damp,damp2,rac2,racut,omega
real(kind=8)::aai,aai2,r2,rjk,dampjk,damp2jk,dampij,damp2ij,dampjl
real(kind=8)::rkl,rjl,dampkl,damp2kl,damp2jl,term1(3),term2(3),term3(3)
integer::ib,id
real(kind=8)::dda(3),ddb(3),ddc(3),ddd(3)
real(kind=8)::rbond(3)
!   The newly added gradient components
real(kind=8)::g_local_a(3),g_local_b(3),g_local_c(3),g_local_d(3)

real(kind=8)::r,thab,thbc,ra(3),fac,eb,or,kij,rij,alpha,dij
real(kind=8)::dei(3),dej(3),dek(3),kijk,rb(3),ea,dedtheta,ban
real(kind=8)::c0,c1,c2,theta,sinth,costh,expo,valijkl
real(kind=8)::dphidri(3),dphidrj(3),dphidrk(3),dphidrl(3),step
real(kind=8)::et,phi0,rn,kijkl,dedphi,phi,cosrph,cosrph0,er,el
real(kind=8)::dphi1,dphi2,x1cos,x2cos,x1sin,x2sin,phipi,e1,e2,ef
integer::i,j,k,l,m,ic,ia,list(4),jj,mm,ii,kk,it,nt,it2

e=0
g=0
!
!     calculate energy and gradients: For all coordinate types, loop over
!     all included coordinates and sum up the parts
!
!     strech terms (bondlengths)
!
do m=1,nbond
   i=bond(1,m)
   j=bond(2,m)
!
!     calculate bondlength
!
   do ic=1,3
      rbond(ic)=xyz(ic,i)-xyz(ic,j)
   end do

!
!     apply periodic boundaries, if needed
!
   if (periodic) then
      call box_image(rbond)
   end if
   r2=rbond(1)**2+rbond(2)**2+rbond(3)**2
   r =sqrt(r2)

   rij=vbond(1,m)
   kij=vbond(2,m)
   aai=vbond(3,m)
   aai2 =aai/2
!
!     the energy
!
   e=e+kij*(1.+(rij/r)**aai-2.*(rij/r)**aai2)
!
!     the gradient
!
   fac=aai*kij*(-(rij/r)**aai+(rij/r)**aai2)/r2
   do ic=1,3
      g_local_a(ic)=fac*rbond(ic)
   end do

   g(:,i)=g(:,i)+g_local_a
   g(:,j)=g(:,j)-g_local_a
!
!     the components of the virial tensor, if needed
!
   if (calc_vir) then
      vir_ten(1,1)=vir_ten(1,1)+rbond(1)*g_local_a(1)
      vir_ten(2,1)=vir_ten(2,1)+rbond(2)*g_local_a(1)
      vir_ten(3,1)=vir_ten(3,1)+rbond(3)*g_local_a(1)
      vir_ten(1,2)=vir_ten(1,2)+rbond(1)*g_local_a(2)
      vir_ten(2,2)=vir_ten(2,2)+rbond(2)*g_local_a(2)
      vir_ten(3,2)=vir_ten(3,2)+rbond(3)*g_local_a(2)
      vir_ten(1,3)=vir_ten(1,3)+rbond(1)*g_local_a(3)
      vir_ten(2,3)=vir_ten(2,3)+rbond(2)*g_local_a(3)
      vir_ten(3,3)=vir_ten(3,3)+rbond(3)*g_local_a(3)
   end if
!
!     If debugging is activated, store the component in the array
!
   if (do_debug) then
      comp_no=m
      act_part=kij*(1.+(rij/r)**aai-2.*(rij/r)**aai2)
      qmdff_parts(1,struc_no,comp_no)=act_part
      write(288,*) &
       &       "bond",i,j," energy",kij*(1.+(rij/r)**aai-2.*(rij/r)**aai2)," eq. length:",r," act. length:",rij, &
       & " f.c.",kij," exp.a.",aai," dr/dxi:", g(1,i)," dr/dyi:", g(2,i)," dr/dzi:", g(3,i)," dr/dxj:", &
       &   g(1,j)," dr/dyj:", g(2,j)," dr/dzj:",g(3,j)
   end if
end do
!
!     bend terms (1-2-3 angles)
!
do m=1,nangl
   j=angl(1,m)
   i=angl(2,m)
   k=angl(3,m)
   c0=vangl(1,m)
   kijk=vangl(2,m)
   va(1:3)=xyz(1:3,i)
   vb(1:3)=xyz(1:3,j)
   vc(1:3)=xyz(1:3,k)

   vab=va-vb
   vcb=vc-vb
!
!     apply periodic boundaries, if needed
!
   if (periodic) then
      call box_image(vab)
      call box_image(vcb)
   end if

!
!     vectors of both included bonds
!
   rab2=vab(1)*vab(1)+vab(2)*vab(2)+vab(3)*vab(3)
   rcb2=vcb(1)*vcb(1)+vcb(2)*vcb(2)+vcb(3)*vcb(3)
!
!     calculate bond angle
!
   call crprod(vcb,vab,vp)
   rp=vlen(vp)+1.d-14
   call impsc(vab,vcb,cosa)
   cosa=dble(min(1.0d0,max(-1.0d0,cosa)))
   theta=dacos(cosa)
!
!     damping for large distances
!
   call abdamp(at(i),at(j),rab2,dampij,damp2ij)
   call abdamp(at(k),at(j),rcb2,dampjk,damp2jk)
   damp=dampij*dampjk
!
!     if the angle is almost linear
!
   if (pi-c0.lt.1.d-6) then
      dt=theta-c0
      ea=kijk*dt**2
      deddt=2.d0*kijk*dt
   else
      ea=kijk*(cosa-cos(c0))**2
      deddt=2.*kijk*sin(theta)*(cos(c0)-cosa)

    end if
!
!     add the calculated energy
!
!     --> for debugging
!
!   if (do_debug) then
!      comp_no=comp_no+1
!      act_part=ea*damp
!      qmdff_parts(1,struc_no,comp_no)=act_part
!      write(parts_labels(1,comp_no),'(a,i4,i4,i4)') "angle",i,j,k
!   end if
   e=e+ea*damp
!
!     calculate the gradient
!
   call crprod(vab,vp,deda)
   rmul1 = -deddt / (rab2*rp)
   deda=deda*rmul1
   call crprod(vcb,vp,dedc)
   rmul2 =  deddt / (rcb2*rp)
   dedc=dedc*rmul2
   dedb=deda+dedc   ! sum of a and c!
   term1(1:3)=ea*damp2ij*dampjk*vab(1:3)
   term2(1:3)=ea*damp2jk*dampij*vcb(1:3)

   g_local_a = deda(1:3)*damp+term1(1:3)
   g_local_b = -dedb(1:3)*damp-term1(1:3)-term2(1:3)
   g_local_c = dedc(1:3)*damp+term2(1:3)

   g(1:3,i)=g(1:3,i)+g_local_a
   g(1:3,j)=g(1:3,j)+g_local_b
   g(1:3,k)=g(1:3,k)+g_local_c
!
!     Calculate the virial tensor components, if needed!
!
   if (calc_vir) then
      vir_ten(1,1)=vir_ten(1,1)+vab(1)*g_local_a(1)+vcb(1)*g_local_c(1)
      vir_ten(2,1)=vir_ten(2,1)+vab(2)*g_local_a(1)+vcb(2)*g_local_c(1)
      vir_ten(3,1)=vir_ten(3,1)+vab(3)*g_local_a(1)+vcb(3)*g_local_c(1)
      vir_ten(1,2)=vir_ten(1,2)+vab(1)*g_local_a(2)+vcb(1)*g_local_c(2)
      vir_ten(2,2)=vir_ten(2,2)+vab(2)*g_local_a(2)+vcb(2)*g_local_c(2)
      vir_ten(3,2)=vir_ten(3,2)+vab(3)*g_local_a(2)+vcb(3)*g_local_c(2)
      vir_ten(1,3)=vir_ten(1,3)+vab(1)*g_local_a(3)+vcb(1)*g_local_c(3)
      vir_ten(2,3)=vir_ten(2,3)+vab(2)*g_local_a(3)+vcb(2)*g_local_c(3)
      vir_ten(3,3)=vir_ten(3,3)+vab(3)*g_local_a(3)+vcb(3)*g_local_c(3)
   end if
!
!     If debugging is activated, store the component in the array
!

   if (do_debug) then
      comp_no=m
      act_part=kij*(1.+(rij/r)**aai-2.*(rij/r)**aai2)
      qmdff_parts(1,struc_no,comp_no)=act_part
      write(289,*) &
       &       "angle",i,j,k, " energy",ea*damp," act. angle:",c0, " eq. angle:",acos(cosa), &
       & " f.c.",kijk," damping.",damp," da/dxi:", g(1,i)," da/dyi:", g(2,i)," da/dzi:", g(3,i)," da/dxj:", &
       &   g(1,j)," da/dyj:", g(2,j)," da/dzj:",g(3,j), "da/dxk:", &
       &   g(1,k)," da/dyk:", g(2,k)," da/dzk:",g(3,k)
   end if

end do
!
!     torsion ter,s
!
do m=1,ntors
!
!     the four involved atoms
!
   i=tors(1,m)
   j=tors(2,m)
   k=tors(3,m)
   l=tors(4,m)
   nt=tors(5,m)
   phi0 =vtors(1,m)
!----------------------------------------------------
!     the normal torsions
!----------------------------------------------------
   if(tors(6,m).ne.2)then
      vab(1:3) = xyz(1:3,i)-xyz(1:3,j)
      vcb(1:3) = xyz(1:3,j)-xyz(1:3,k)
      vdc(1:3) = xyz(1:3,k)-xyz(1:3,l)
!
!     apply periodic boundaries, if needed
!
      if (periodic) then
         call box_image(vab)
         call box_image(vcb)
         call box_image(vdc)
      end if

!
!     three bondlengths are needed
!
      rij = vab(1)*vab(1) + vab(2)*vab(2) + vab(3)*vab(3)
      rjk = vcb(1)*vcb(1) + vcb(2)*vcb(2) + vcb(3)*vcb(3)
      rkl = vdc(1)*vdc(1) + vdc(2)*vdc(2) + vdc(3)*vdc(3)
!
!     calculate all damping functions
!
      call abdamp(at(i),at(j),rij,dampij,damp2ij)
      call abdamp(at(k),at(j),rjk,dampjk,damp2jk)
      call abdamp(at(k),at(l),rkl,dampkl,damp2kl)
      damp= dampjk*dampij*dampkl
!
!     the torsional angle phi
!
      phi=valijkl(n,xyz,i,j,k,l)
      call dphidr(n,xyz,i,j,k,l,phi,dda,ddb,ddc,ddd)

      et=0
      dij=0
      mm=3!
!
!     loop over the number of torsional minima along curve
!
      if (do_debug) then
         write(290,'(a,i4,i4,i4,i4)') "torsion",i,j,k,l
      end if
      do it=1,nt
         rn=vtors(mm,m)
         dphi1=phi-phi0
         dphi2=phi+phi0-pi2
         c1=rn*dphi1+vtors(mm+1,m)
         c2=rn*dphi2+vtors(mm+1,m)
         x1cos=cos(c1)
         x2cos=cos(c2)
         x1sin=sin(c1)
         x2sin=sin(c2)
         phipi=phi-pi
!
!     deviation of the angle from linearity (=pi)
!
         ef=erf(phipi)
         e1=vtors(mm+2,m)*(1.+x1cos)
         e2=vtors(mm+2,m)*(1.+x2cos)
         et=et+0.5*(1.-ef)*e1+(0.5+0.5*ef)*e2
         expo=exp(-phipi**2)/spi
         dij=dij-expo*e1- 0.5*(1.-ef)*vtors(mm+2,m)*x1sin*rn+ &
           &   expo*e2-(0.5+0.5*ef)*vtors(mm+2,m)*x2sin*rn
         if (do_debug) then
       !      write(*,*) it,mm,e1,e2,phi,phi0,dampjk,dampij,dampkl,damp,c1,c2,vtors(2,m)
            write(290,*) "Minimum No.",it,"of",nt,"damp(ij)",dampij,"damp(jk)",dampjk,&
                       & "damp(kl)",dampkl,"damp_tot",damp,"eq. angle",phi0,"act. angle",phi,"force const.",vtors(2,m)

         end if
         mm=mm+3
      end do
!
!     sum up the torsional energy
!
!     --> for debugging
!
!   if (do_debug) then
!      comp_no=comp_no+1
!      act_part=ea*damp
!      qmdff_parts(1,struc_no,comp_no)=act_part
!      write(parts_labels(1,comp_no),'(a,i4,i4,i4,i4)') "torsion",i,j,k,l
!   end if

      et=et*vtors(2,m)
!
!     the torsional gradient!
!
      dij=dij*vtors(2,m)*damp

      term1(1:3)=et*damp2ij*dampjk*dampkl*vab(1:3)
      term2(1:3)=et*damp2jk*dampij*dampkl*vcb(1:3)
      term3(1:3)=et*damp2kl*dampij*dampjk*vdc(1:3)

      g_local_a = dij*dda(1:3)+term1
      g_local_b = dij*ddb(1:3)-term1+term2
      g_local_c = dij*ddc(1:3)+term3-term2
      g_local_d = dij*ddd(1:3)-term3

      g(1:3,i)=g(1:3,i)+g_local_a
      g(1:3,j)=g(1:3,j)+g_local_b
      g(1:3,k)=g(1:3,k)+g_local_c
      g(1:3,l)=g(1:3,l)+g_local_d

!
!     Calculate the virial tensor components, if needed!
!

      if (calc_vir) then
         vir_ten(1,1)=vir_ten(1,1)+vab(1)*g_local_a(1)+vcb(1)*(g_local_c(1)+ &
                     & g_local_d(1))+vdc(1)*g_local_d(1)
         vir_ten(2,1)=vir_ten(2,1)+vab(2)*g_local_a(1)+vcb(2)*(g_local_c(1)+ &
                     & g_local_d(1))+vdc(2)*g_local_d(1)
         vir_ten(3,1)=vir_ten(3,1)+vab(3)*g_local_a(1)+vcb(3)*(g_local_c(1)+ &
                     & g_local_d(1))+vdc(3)*g_local_d(1)
         vir_ten(1,2)=vir_ten(1,2)+vab(1)*g_local_a(2)+vcb(1)*(g_local_c(2)+ &
                     & g_local_d(2))+vdc(1)*g_local_d(2)
         vir_ten(2,2)=vir_ten(2,2)+vab(2)*g_local_a(2)+vcb(2)*(g_local_c(2)+ &
                     & g_local_d(2))+vdc(2)*g_local_d(2)
         vir_ten(3,2)=vir_ten(3,2)+vab(3)*g_local_a(2)+vcb(3)*(g_local_c(2)+ &
                     & g_local_d(2))+vdc(3)*g_local_d(2)
         vir_ten(1,3)=vir_ten(1,3)+vab(1)*g_local_a(3)+vcb(1)*(g_local_c(3)+ &
                     & g_local_d(3))+vdc(1)*g_local_d(3)
         vir_ten(2,3)=vir_ten(2,3)+vab(2)*g_local_a(3)+vcb(2)*(g_local_c(3)+ &
                     & g_local_d(3))+vdc(2)*g_local_d(3)
         vir_ten(3,3)=vir_ten(3,3)+vab(3)*g_local_a(3)+vcb(3)*(g_local_c(3)+ &
                     & g_local_d(3))+vdc(3)*g_local_d(3)
      end if

!
!     If debugging is activated, store the component in the array
!

      if (do_debug) then
         comp_no=m
         write(290,*) &
          &       "total energy",et, &
          & " dt/dxi:", g(1,i)," dt/dyi:", g(2,i)," dt/dzi:", g(3,i)," dt/dxj:", &
          &   g(1,j)," dt/dyj:", g(2,j)," dt/dzj:",g(3,j),"dt/dxk:", &
          &   g(1,k)," dt/dyk:", g(2,k)," dt/dzk:",g(3,k),"dt/dxl:", &
          &   g(1,l)," dt/dyl:", g(2,l)," dt/dzl:",g(3,l)
      end if

!
!     scale energy by damping factor
!
!     --> for debugging
!
!      if (do_debug) then
!         comp_no=nbond+nangl+m
!         act_part=et*damp
!         qmdff_parts(1,struc_no,comp_no)=act_part
!      end if
      e=e+et*damp
!----------------------------------------------------
!     torsions for inversions!
!----------------------------------------------------
   else
!
!     do basically the same as above...
!
      vab(1:3) = xyz(1:3,j)-xyz(1:3,i)
      vcb(1:3) = xyz(1:3,j)-xyz(1:3,k)
      vdc(1:3) = xyz(1:3,j)-xyz(1:3,l)
!
!     apply periodic boundaries, if needed
!
      if (periodic) then
         call box_image(vab)
         call box_image(vcb)
         call box_image(vdc)
      end if

      rij = vab(1)*vab(1) + vab(2)*vab(2) + vab(3)*vab(3)
      rjk = vcb(1)*vcb(1) + vcb(2)*vcb(2) + vcb(3)*vcb(3)
      rjl = vdc(1)*vdc(1) + vdc(2)*vdc(2) + vdc(3)*vdc(3)
      call abdamp(at(i),at(j),rij,dampij,damp2ij)
      call abdamp(at(k),at(j),rjk,dampjk,damp2jk)
      call abdamp(at(j),at(l),rjl,dampjl,damp2jl)
      damp= dampjk*dampij*dampjl

      phi=omega(n,xyz,i,j,k,l)
      call domegadr(n,xyz,i,j,k,l,phi,dda,ddb,ddc,ddd)

      rn=vtors(3,m)
      if (rn.gt.1.d-6)then
         dphi1=phi-phi0
         c1=dphi1+pi
         x1cos=cos(c1)
         x1sin=sin(c1)
         et   =(1.+x1cos)*vtors(2,m)
         dij  =-x1sin*vtors(2,m)*damp
      else
         et =   vtors(2,m)*(cos(phi) -cos(phi0))**2
         dij=2.*vtors(2,m)* sin(phi)*(cos(phi0)-cos(phi))*damp
      end if

      term1(1:3)=et*damp2ij*dampjk*dampjl*vab(1:3)
      term2(1:3)=et*damp2jk*dampij*dampjl*vcb(1:3)
      term3(1:3)=et*damp2jl*dampij*dampjk*vdc(1:3)

      g_local_a = dij*dda(1:3)-term1
      g_local_b = dij*ddb(1:3)+term1+term2+term3
      g_local_c = dij*ddc(1:3)-term2
      g_local_d = dij*ddd(1:3)-term3

      g(1:3,i)=g(1:3,i)+g_local_a
      g(1:3,j)=g(1:3,j)+g_local_b
      g(1:3,k)=g(1:3,k)+g_local_c
      g(1:3,l)=g(1:3,l)+g_local_d
      e=e+et*damp

!
!     Calculate the virial tensor components, if needed!
!     a=i   b=j   c=k  d=l
!     --> Maybe the out of plane variant needed with b as central atom??
!
      if (calc_vir) then
         vir_ten(1,1)=vir_ten(1,1)+vab(1)*g_local_a(1)+vcb(1)*(g_local_c(1)+ &
                     & g_local_d(1))+vdc(1)*g_local_d(1)
         vir_ten(2,1)=vir_ten(2,1)+vab(2)*g_local_a(1)+vcb(2)*(g_local_c(1)+ &
                    & g_local_d(1))+vdc(2)*g_local_d(1)
         vir_ten(3,1)=vir_ten(3,1)+vab(3)*g_local_a(1)+vcb(3)*(g_local_c(1)+ &
                     & g_local_d(1))+vdc(3)*g_local_d(1)
         vir_ten(1,2)=vir_ten(1,2)+vab(1)*g_local_a(2)+vcb(1)*(g_local_c(2)+ &
                     & g_local_d(2))+vdc(1)*g_local_d(2)
         vir_ten(2,2)=vir_ten(2,2)+vab(2)*g_local_a(2)+vcb(2)*(g_local_c(2)+ &
                     & g_local_d(2))+vdc(2)*g_local_d(2)
         vir_ten(3,2)=vir_ten(3,2)+vab(3)*g_local_a(2)+vcb(3)*(g_local_c(2)+ &
                     & g_local_d(2))+vdc(3)*g_local_d(2)
         vir_ten(1,3)=vir_ten(1,3)+vab(1)*g_local_a(3)+vcb(1)*(g_local_c(3)+ &
                     & g_local_d(3))+vdc(1)*g_local_d(3)
         vir_ten(2,3)=vir_ten(2,3)+vab(2)*g_local_a(3)+vcb(2)*(g_local_c(3)+ &
                     & g_local_d(3))+vdc(2)*g_local_d(3)
         vir_ten(3,3)=vir_ten(3,3)+vab(3)*g_local_a(3)+vcb(3)*(g_local_c(3)+ &
                     & g_local_d(3))+vdc(3)*g_local_d(3)
      end if

!
!     --> for debugging
!
!      if (do_debug) then
!         comp_no=comp_no+1
!         act_part=et*damp
!         qmdff_parts(1,struc_no,comp_no)=act_part
!         write(parts_labels(1,comp_no),'(a,i4,i4,i4,i4)') "inversopm",i,j,k,l
!      end if

   end if
end do

!
!     here restraints can be added!
!     maybe some metal surface could be simulated using restraints???
!
!      call egrestrain(n,xyz,g,er)
!      e = e + er
!

return
end subroutine ff_eg


!     path:      $Source$
!     author:    $Author: miacono $
!     revision:  $Revision: 29812 $
!     created:   $Date: 2016-09-02 17:01:49 -0400 (Fri, 02 Sep 2016) $

      module rrtmg_sw_cldprop

!----------------------------------------------------------------------------
! Copyright (c) 2002-2016, Atmospheric & Environmental Research, Inc. (AER)
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!  * Redistributions of source code must retain the above copyright
!    notice, this list of conditions and the following disclaimer.
!  * Redistributions in binary form must reproduce the above copyright
!    notice, this list of conditions and the following disclaimer in the
!    documentation and/or other materials provided with the distribution.
!  * Neither the name of Atmospheric & Environmental Research, Inc., nor
!    the names of its contributors may be used to endorse or promote products
!    derived from this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
! ARE DISCLAIMED. IN NO EVENT SHALL ATMOSPHERIC & ENVIRONMENTAL RESEARCH, INC.,
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF
! THE POSSIBILITY OF SUCH DAMAGE.
!                        (http://www.rtweb.aer.com/)
!----------------------------------------------------------------------------

! ------- Modules -------

      use parkind, only : im => kind_im, rb => kind_rb
      use parrrsw, only : nbndsw, jpband, jpb1, jpb2
      use rrsw_cld, only : extliq1, ssaliq1, asyliq1, &
                           extice2, ssaice2, asyice2, &
                           extice3, ssaice3, asyice3, fdlice3, &
                           abari, bbari, cbari, dbari, ebari, fbari
      use rrsw_wvn, only : wavenum1, wavenum2
      use rrsw_vsn, only : hvrcld, hnamcld

      implicit none

      contains

! ----------------------------------------------------------------------------
      subroutine cldprop_sw(nlayers, inflag, iceflag, liqflag, cldfrac, &
                            tauc, ssac, asmc, fsfc, ciwp, clwp, rei, rel, &
                            taucldorig, taucloud, ssacloud, asmcloud)
! ----------------------------------------------------------------------------

! Purpose: Compute the cloud optical properties for each cloudy layer.
! Note: Only inflag = 0 and inflag=2/liqflag=1/iceflag=1,2,3 are available;
! (Hu & Stamnes, Ebert and Curry, Key, and Fu) are implemented.

! ------- Input -------

      integer(kind=im), intent(in) :: nlayers         ! total number of layers
      integer(kind=im), intent(in) :: inflag          ! see definitions
      integer(kind=im), intent(in) :: iceflag         ! see definitions
      integer(kind=im), intent(in) :: liqflag         ! see definitions

      real(kind=rb), intent(in) :: cldfrac(:)         ! cloud fraction
                                                      !    Dimensions: (nlayers)
      real(kind=rb), intent(in) :: ciwp(:)            ! cloud ice water path
                                                      !    Dimensions: (nlayers)
      real(kind=rb), intent(in) :: clwp(:)            ! cloud liquid water path
                                                      !    Dimensions: (nlayers)
      real(kind=rb), intent(in) :: rei(:)             ! cloud ice particle effective size (microns)
                                                      !    Dimensions: (nlayers)
                                                      ! specific definition of rei depends on setting of iceflag:
                                                      ! iceflag = 0: (inactive)
                                                      !
                                                      ! iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
                                                      !              r_ec range is limited to 13.0 to 130.0 microns
                                                      ! iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
                                                      !              r_k range is limited to 5.0 to 131.0 microns
                                                      ! iceflag = 3: generalized effective size, dge, (Fu, 1996),
                                                      !              dge range is limited to 5.0 to 140.0 microns
                                                      !              [dge = 1.0315 * r_ec]
      real(kind=rb), intent(in) :: rel(:)             ! cloud liquid particle effective radius (microns)
                                                      !    Dimensions: (nlayers)
      real(kind=rb), intent(in) :: tauc(:,:)          ! cloud optical depth
                                                      !    Dimensions: (nbndsw,nlayers)
      real(kind=rb), intent(in) :: ssac(:,:)          ! single scattering albedo
                                                      !    Dimensions: (nbndsw,nlayers)
      real(kind=rb), intent(in) :: asmc(:,:)          ! asymmetry parameter
                                                      !    Dimensions: (nbndsw,nlayers)
      real(kind=rb), intent(in) :: fsfc(:,:)          ! forward scattering fraction
                                                      !    Dimensions: (nbndsw,nlayers)

! ------- Output -------

      real(kind=rb), intent(out) :: taucloud(:,:)     ! cloud optical depth (delta scaled)
                                                      !    Dimensions: (nlayers,jpband)
      real(kind=rb), intent(out) :: taucldorig(:,:)   ! cloud optical depth (non-delta scaled)
                                                      !    Dimensions: (nlayers,jpband)
      real(kind=rb), intent(out) :: ssacloud(:,:)     ! single scattering albedo (delta scaled)
                                                      !    Dimensions: (nlayers,jpband)
      real(kind=rb), intent(out) :: asmcloud(:,:)     ! asymmetry parameter (delta scaled)
                                                      !    Dimensions: (nlayers,jpband)

! ------- Local -------

!      integer(kind=im) :: ncbands
      integer(kind=im) :: ib, ib1, ib2, lay, istr, index, icx

      real(kind=rb), parameter :: eps = 1.e-06_rb     ! epsilon
      real(kind=rb), parameter :: cldmin = 1.e-20_rb  ! minimum value for cloud quantities
      real(kind=rb) :: cwp                            ! total cloud water path
      real(kind=rb) :: radliq                         ! cloud liquid droplet radius (microns)
      real(kind=rb) :: radice                         ! cloud ice effective size (microns)
      real(kind=rb) :: factor
      real(kind=rb) :: fint
      real(kind=rb) :: tauctot(nlayers)               ! band integrated cloud optical depth

      real(kind=rb) :: taucldorig_a, ssacloud_a, taucloud_a, ffp, ffp1, ffpssa
      real(kind=rb) :: tauiceorig, scatice, ssaice, tauice, tauliqorig, scatliq, ssaliq, tauliq

      real(kind=rb) :: fdelta(jpb1:jpb2)
      real(kind=rb) :: extcoice(jpb1:jpb2), gice(jpb1:jpb2)
      real(kind=rb) :: ssacoice(jpb1:jpb2), forwice(jpb1:jpb2)
      real(kind=rb) :: extcoliq(jpb1:jpb2), gliq(jpb1:jpb2)
      real(kind=rb) :: ssacoliq(jpb1:jpb2), forwliq(jpb1:jpb2)

! Initialize

      hvrcld = '$Revision: 29812 $'

!      ncbands = 29
      ib1 = jpb1
      ib2 = jpb2
      tauctot(:) = 0._rb

      do lay = 1, nlayers
         do ib = ib1 , ib2
            taucldorig(lay,ib) = tauc(ib-15,lay)
            taucloud(lay,ib) = 0.0_rb
            ssacloud(lay,ib) = 1.0_rb
            asmcloud(lay,ib) = 0.0_rb
            tauctot(lay) = tauctot(lay) + tauc(ib-15,lay)
         enddo
      enddo

! Main layer loop
      do lay = 1, nlayers

         cwp = ciwp(lay) + clwp(lay)
         if (cldfrac(lay) .ge. cldmin .and. &
            (cwp .ge. cldmin .or. tauctot(lay) .ge. cldmin)) then

! (inflag=0): Cloud optical properties input directly
! Cloud optical properties already defined in tauc, ssac, asmc are unscaled;
! Apply delta-M scaling here
            if (inflag .eq. 0) then

               do ib = ib1 , ib2
                  taucldorig_a = tauc(ib-15,lay)
                  ffp = fsfc(ib-15,lay)
                  ffp1 = 1.0_rb - ffp
                  ffpssa = 1.0_rb - ffp * ssac(ib-15,lay)
                  ssacloud_a = ffp1 * ssac(ib-15,lay) / ffpssa
                  taucloud_a = ffpssa * taucldorig_a

                  taucldorig(lay,ib) = taucldorig_a
                  ssacloud(lay,ib) = ssacloud_a
                  taucloud(lay,ib) = taucloud_a
                  asmcloud(lay,ib) = (asmc(ib-15,lay) - ffp) / (ffp1)
               enddo

! (inflag=2): Separate treatement of ice clouds and water clouds.
            elseif (inflag .eq. 2) then
               radice = rei(lay)

! Calculation of absorption coefficients due to ice clouds.
               if (ciwp(lay) .eq. 0.0_rb) then
                  do ib = ib1 , ib2
                     extcoice(ib) = 0.0_rb
                     ssacoice(ib) = 0.0_rb
                     gice(ib)     = 0.0_rb
                     forwice(ib)  = 0.0_rb
                  enddo

! (iceflag = 1):
! Note: This option uses Ebert and Curry approach for all particle sizes similar to
! CAM3 implementation, though this is somewhat ineffective for large ice particles
               elseif (iceflag .eq. 1) then
                  if (radice .lt. 13.0_rb .or. radice .gt. 130._rb) stop &
                     'ICE RADIUS OUT OF BOUNDS'
                  do ib = ib1, ib2
                     if (wavenum2(ib) .gt. 1.43e04_rb) then
                        icx = 1
                     elseif (wavenum2(ib) .gt. 7.7e03_rb) then
                        icx = 2
                     elseif (wavenum2(ib) .gt. 5.3e03_rb) then
                        icx = 3
                     elseif (wavenum2(ib) .gt. 4.0e03_rb) then
                        icx = 4
                     elseif (wavenum2(ib) .ge. 2.5e03_rb) then
                        icx = 5
                     endif
                     extcoice(ib) = abari(icx) + bbari(icx)/radice
                     ssacoice(ib) = 1._rb - cbari(icx) - dbari(icx) * radice
                     gice(ib) = ebari(icx) + fbari(icx) * radice

! Check to ensure upper limit of gice is within physical limits for large particles
                     if (gice(ib) .ge. 1.0_rb) gice(ib) = 1.0_rb - eps
                     forwice(ib) = gice(ib)*gice(ib)
! Check to ensure all calculated quantities are within physical limits.
                     if (extcoice(ib) .lt. 0.0_rb) stop 'ICE EXTINCTION LESS THAN 0.0'
                     if (ssacoice(ib) .gt. 1.0_rb) stop 'ICE SSA GRTR THAN 1.0'
                     if (ssacoice(ib) .lt. 0.0_rb) stop 'ICE SSA LESS THAN 0.0'
                     if (gice(ib) .gt. 1.0_rb) stop 'ICE ASYM GRTR THAN 1.0'
                     if (gice(ib) .lt. 0.0_rb) stop 'ICE ASYM LESS THAN 0.0'
                  enddo

! For iceflag=2 option, ice particle effective radius is limited to 5.0 to 131.0 microns

               elseif (iceflag .eq. 2) then
                  if (radice .lt. 5.0_rb .or. radice .gt. 131.0_rb) stop 'ICE RADIUS OUT OF BOUNDS'
                  factor = (radice - 2._rb)/3._rb
                  index = int(factor)
                  if (index .eq. 43) index = 42
                  fint = factor - real(index,kind=rb)
                  do ib = ib1, ib2
                     extcoice(ib) = extice2(index,ib) + fint * &
                                   (extice2(index+1,ib) -  extice2(index,ib))
                     ssacoice(ib) = ssaice2(index,ib) + fint * &
                                   (ssaice2(index+1,ib) -  ssaice2(index,ib))
                     gice(ib) = asyice2(index,ib) + fint * &
                                   (asyice2(index+1,ib) -  asyice2(index,ib))
                     forwice(ib) = gice(ib)*gice(ib)
! Check to ensure all calculated quantities are within physical limits.
                     if (extcoice(ib) .lt. 0.0_rb) stop 'ICE EXTINCTION LESS THAN 0.0'
                     if (ssacoice(ib) .gt. 1.0_rb) stop 'ICE SSA GRTR THAN 1.0'
                     if (ssacoice(ib) .lt. 0.0_rb) stop 'ICE SSA LESS THAN 0.0'
                     if (gice(ib) .gt. 1.0_rb) stop 'ICE ASYM GRTR THAN 1.0'
                     if (gice(ib) .lt. 0.0_rb) stop 'ICE ASYM LESS THAN 0.0'
                  enddo

! For iceflag=3 option, ice particle generalized effective size is limited to 5.0 to 140.0 microns

               elseif (iceflag .eq. 3) then
                  if (radice .lt. 5.0_rb .or. radice .gt. 140.0_rb) stop 'ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS'
                  factor = (radice - 2._rb)/3._rb
                  index = int(factor)
                  if (index .eq. 46) index = 45
                  fint = factor - real(index,kind=rb)
                  do ib = ib1 , ib2
                     extcoice(ib) = extice3(index,ib) + fint * &
                                   (extice3(index+1,ib) - extice3(index,ib))
                     ssacoice(ib) = ssaice3(index,ib) + fint * &
                                   (ssaice3(index+1,ib) - ssaice3(index,ib))
                     gice(ib) = asyice3(index,ib) + fint * &
                               (asyice3(index+1,ib) - asyice3(index,ib))
                     fdelta(ib) = fdlice3(index,ib) + fint * &
                                 (fdlice3(index+1,ib) - fdlice3(index,ib))
                     if (fdelta(ib) .lt. 0.0_rb) stop 'FDELTA LESS THAN 0.0'
                     if (fdelta(ib) .gt. 1.0_rb) stop 'FDELTA GT THAN 1.0'
                     forwice(ib) = fdelta(ib) + 0.5_rb / ssacoice(ib)
! See Fu 1996 p. 2067
                     if (forwice(ib) .gt. gice(ib)) forwice(ib) = gice(ib)
! Check to ensure all calculated quantities are within physical limits.
                     if (extcoice(ib) .lt. 0.0_rb) stop 'ICE EXTINCTION LESS THAN 0.0'
                     if (ssacoice(ib) .gt. 1.0_rb) stop 'ICE SSA GRTR THAN 1.0'
                     if (ssacoice(ib) .lt. 0.0_rb) stop 'ICE SSA LESS THAN 0.0'
                     if (gice(ib) .gt. 1.0_rb) stop 'ICE ASYM GRTR THAN 1.0'
                     if (gice(ib) .lt. 0.0_rb) stop 'ICE ASYM LESS THAN 0.0'
                  enddo

               endif

! Calculation of absorption coefficients due to water clouds.
                if (clwp(lay) .eq. 0.0_rb) then
                   do ib = ib1 , ib2
                      extcoliq(ib) = 0.0_rb
                      ssacoliq(ib) = 0.0_rb
                      gliq(ib) = 0.0_rb
                      forwliq(ib) = 0.0_rb
                   enddo

                elseif (liqflag .eq. 1) then
                   radliq = rel(lay)
                   if (radliq .lt. 2.5_rb .or. radliq .gt. 60._rb) stop &
                      'LIQUID EFFECTIVE RADIUS OUT OF BOUNDS'
                   index = int(radliq - 1.5_rb)
                   if (index .eq. 0) index = 1
                   if (index .eq. 58) index = 57
                   fint = radliq - 1.5_rb - real(index,kind=rb)
                   do ib = ib1 , ib2
                      extcoliq(ib) = extliq1(index,ib) + fint * &
                                    (extliq1(index+1,ib) - extliq1(index,ib))
                      ssacoliq(ib) = ssaliq1(index,ib) + fint * &
                                    (ssaliq1(index+1,ib) - ssaliq1(index,ib))
                      if (fint .lt. 0._rb .and. ssacoliq(ib) .gt. 1._rb) &
                                     ssacoliq(ib) = ssaliq1(index,ib)
                      gliq(ib) = asyliq1(index,ib) + fint * &
                                (asyliq1(index+1,ib) - asyliq1(index,ib))
                      forwliq(ib) = gliq(ib)*gliq(ib)
! Check to ensure all calculated quantities are within physical limits.
                      if (extcoliq(ib) .lt. 0.0_rb) stop 'LIQUID EXTINCTION LESS THAN 0.0'
                      if (ssacoliq(ib) .gt. 1.0_rb) stop 'LIQUID SSA GRTR THAN 1.0'
                      if (ssacoliq(ib) .lt. 0.0_rb) stop 'LIQUID SSA LESS THAN 0.0'
                      if (gliq(ib) .gt. 1.0_rb) stop 'LIQUID ASYM GRTR THAN 1.0'
                      if (gliq(ib) .lt. 0.0_rb) stop 'LIQUID ASYM LESS THAN 0.0'
                   enddo
                endif

                do ib = ib1 , ib2
                   tauliqorig = clwp(lay) * extcoliq(ib)
                   tauiceorig = ciwp(lay) * extcoice(ib)
                   taucldorig(lay,ib) = tauliqorig + tauiceorig

                   ssaliq = ssacoliq(ib) * (1.0_rb - forwliq(ib)) / &
                           (1.0_rb - forwliq(ib) * ssacoliq(ib))
                   tauliq = (1.0_rb - forwliq(ib) * ssacoliq(ib)) * tauliqorig
                   ssaice = ssacoice(ib) * (1.0_rb - forwice(ib)) / &
                           (1.0_rb - forwice(ib) * ssacoice(ib))
                   tauice = (1.0_rb - forwice(ib) * ssacoice(ib)) * tauiceorig

                   scatliq = ssaliq * tauliq
                   scatice = ssaice * tauice

                   taucloud(lay,ib) = tauliq + tauice

! Ensure non-zero taucmc and scatice
                   if (taucloud(lay,ib).eq.0.0_rb) taucloud(lay,ib) = cldmin
                   if (scatice.eq.0.0_rb) scatice = cldmin

                   ssacloud(lay,ib) = (scatliq + scatice) / taucloud(lay,ib)

                   if (iceflag .eq. 3) then
! In accordance with the 1996 Fu paper, equation A.3,
! the moments for ice were calculated depending on whether using spheres
! or hexagonal ice crystals.
                      istr = 1
                      asmcloud(lay,ib) = (1.0_rb/(scatliq+scatice)) * &
                         (scatliq*(gliq(ib)**istr - forwliq(ib)) / &
                         (1.0_rb - forwliq(ib)) + scatice * ((gice(ib)-forwice(ib)) / &
                         (1.0_rb - forwice(ib)))**istr)
                   else
! This code is the standard method for delta-m scaling.
                      istr = 1
                      asmcloud(lay,ib) = (scatliq *  &
                         (gliq(ib)**istr - forwliq(ib)) / &
                         (1.0_rb - forwliq(ib)) + scatice * (gice(ib)**istr - forwice(ib)) / &
                         (1.0_rb - forwice(ib)))/(scatliq + scatice)
                   endif

                enddo

            endif

         endif

! End layer loop
      enddo

      end subroutine cldprop_sw

      end module rrtmg_sw_cldprop


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     subroutine ff_eg_three: energies and gradients of the bonded
!            potential terms for the third QMDFF
!
!     part of QMDFF
!

subroutine ff_eg_three(n,at,xyz,e,g)
use qmdff
implicit none
integer::n,at(n)
real(kind=8)::xyz(3,n),e,g(3,n)

real(kind=8)::vp(3),dt,deddt,rp,cosa,rab2,rcb2,vlen,rmul1,rmul2
real(kind=8)::cosna(4),sinna(4),v(4),sa(4),ca(4),phix(4),dphi(4)
real(kind=8)::va(3),vb(3),vc(3),vd(3),vba(3),vcb(3),vdc(3),vab(3)
real(kind=8)::vca(3),vdb(3),vt(3),vu(3),vtu(3),dedt(3),dedu(3)
real(kind=8)::deda(3),dedb(3),dedc(3),dedd(3),vtmp1(3),vtmp2(3)
real(kind=8)::rt2,ru2,rtu,rcb,rtru,damp,damp2,rac2,racut,omega
real(kind=8)::aai,aai2,r2,rjk,dampjk,damp2jk,dampij,damp2ij,dampjl
real(kind=8)::rkl,rjl,dampkl,damp2kl,damp2jl,term1(3),term2(3),term3(3)
integer::ib,id
real(kind=8)::dda(3),ddb(3),ddc(3),ddd(3)

real(kind=8)::r,thab,thbc,ra(3),fac,eb,or,kij,rij,alpha,dij
real(kind=8)::dei(3),dej(3),dek(3),kijk,rb(3),ea,dedtheta,ban
real(kind=8)::c0,c1,c2,theta,sinth,costh,expo,valijkl
real(kind=8)::dphidri(3),dphidrj(3),dphidrk(3),dphidrl(3),step
real(kind=8)::et,phi0,rn,kijkl,dedphi,phi,cosrph,cosrph0,er,el
real(kind=8)::dphi1,dphi2,x1cos,x2cos,x1sin,x2sin,phipi,e1,e2,ef
integer::i,j,k,l,m,ic,ia,list(4),jj,mm,ii,kk,it,nt,it2

e=0
g=0
!
!     calculate energy and gradiens: For all coordinate types, loop over
!     all included coordinates and sum up the parts
!
!     strech terms (bondlengths)
!
do m=1,nbond_three
   i=bond_three(1,m)
   j=bond_three(2,m)
!
!     calculate bondlength
!
   r2=((xyz(1,i)-xyz(1,j))**2 &
     &  +(xyz(2,i)-xyz(2,j))**2 &
     &  +(xyz(3,i)-xyz(3,j))**2)
   r =sqrt(r2)
   do ic=1,3
      ra(ic)=xyz(ic,i)-xyz(ic,j)
   end do
   rij=vbond_three(1,m)
   kij=vbond_three(2,m)
   aai=vbond_three(3,m)
   aai2 =aai/2
!
!     the energy
!
   e=e+kij*(1.+(rij/r)**aai-2.*(rij/r)**aai2)
!
!     the gradient
!
   fac=aai*kij*(-(rij/r)**aai+(rij/r)**aai2)/r2
   do ic=1,3
      g(ic,i)=g(ic,i)+fac*ra(ic)
      g(ic,j)=g(ic,j)-fac*ra(ic)
   end do
end do
!
!     bend terms (1-2-3 angles)
!
do m=1,nangl_three
   j=angl_three(1,m)
   i=angl_three(2,m)
   k=angl_three(3,m)
   c0=vangl_three(1,m)
   kijk=vangl_three(2,m)
   va(1:3)=xyz(1:3,i)
   vb(1:3)=xyz(1:3,j)
   vc(1:3)=xyz(1:3,k)
   vab=va-vb
   vcb=vc-vb
!
!     vectors of both included bonds
!
   rab2=vab(1)*vab(1)+vab(2)*vab(2)+vab(3)*vab(3)
   rcb2=vcb(1)*vcb(1)+vcb(2)*vcb(2)+vcb(3)*vcb(3)
!
!     calculate bond angle
!
   call crprod(vcb,vab,vp)
   rp=vlen(vp)+1.d-14
   call impsc(vab,vcb,cosa)
   cosa=dble(min(1.0d0,max(-1.0d0,cosa)))
   theta=dacos(cosa)
!
!     damping for large distances
!
   call abdamp(at(i),at(j),rab2,dampij,damp2ij)
   call abdamp(at(k),at(j),rcb2,dampjk,damp2jk)
   damp=dampij*dampjk
!
!     if the angle is almost linear
!
   if (pi-c0.lt.1.d-6) then
      dt=theta-c0
      ea=kijk*dt**2
      deddt=2.d0*kijk*dt
   else
      ea=kijk*(cosa-cos(c0))**2
      deddt=2.*kijk*sin(theta)*(cos(c0)-cosa)
   end if
!
!     add the calculated energy
!
   e=e+ea*damp
!
!     calculate the gradient
!
   call crprod(vab,vp,deda)
   rmul1 = -deddt / (rab2*rp)
   deda=deda*rmul1
   call crprod(vcb,vp,dedc)
   rmul2 =  deddt / (rcb2*rp)
   dedc=dedc*rmul2
   dedb=deda+dedc
   term1(1:3)=ea*damp2ij*dampjk*vab(1:3)
   term2(1:3)=ea*damp2jk*dampij*vcb(1:3)
   g(1:3,i) = g(1:3,i) + deda(1:3)*damp+term1(1:3)
   g(1:3,j) = g(1:3,j) - dedb(1:3)*damp-term1(1:3)-term2(1:3)
   g(1:3,k) = g(1:3,k) + dedc(1:3)*damp+term2(1:3)
end do
!
!     torsion ter,s
!
do m=1,ntors_three
!
!     the four involved atoms
!
   i=tors_three(1,m)
   j=tors_three(2,m)
   k=tors_three(3,m)
   l=tors_three(4,m)
   nt=tors_three(5,m)
   phi0 =vtors_three(1,m)
!----------------------------------------------------
!     the normal torsions
!----------------------------------------------------
   if(tors_three(6,m).ne.2)then
      vab(1:3) = xyz(1:3,i)-xyz(1:3,j)
      vcb(1:3) = xyz(1:3,j)-xyz(1:3,k)
      vdc(1:3) = xyz(1:3,k)-xyz(1:3,l)
!
!     three bondlengths are needed
!
      rij = vab(1)*vab(1) + vab(2)*vab(2) + vab(3)*vab(3)
      rjk = vcb(1)*vcb(1) + vcb(2)*vcb(2) + vcb(3)*vcb(3)
      rkl = vdc(1)*vdc(1) + vdc(2)*vdc(2) + vdc(3)*vdc(3)
!
!     calculate all damping functions
!
      call abdamp(at(i),at(j),rij,dampij,damp2ij)
      call abdamp(at(k),at(j),rjk,dampjk,damp2jk)
      call abdamp(at(k),at(l),rkl,dampkl,damp2kl)
      damp= dampjk*dampij*dampkl
!
!     the torsional angle phi
!
      phi=valijkl(n,xyz,i,j,k,l)
      call dphidr(n,xyz,i,j,k,l,phi,dda,ddb,ddc,ddd)

      et=0
      dij=0
      mm=3!
!
!     loop over the number of torsional minima along curve
!
      do it=1,nt
         rn=vtors_three(mm,m)
         dphi1=phi-phi0
         dphi2=phi+phi0-pi2
         c1=rn*dphi1+vtors_three(mm+1,m)
         c2=rn*dphi2+vtors_three(mm+1,m)
         x1cos=cos(c1)
         x2cos=cos(c2)
         x1sin=sin(c1)
         x2sin=sin(c2)
         phipi=phi-pi
!
!     deviation of the angle from linearity (=pi)
!
         ef=erf(phipi)
         e1=vtors_three(mm+2,m)*(1.+x1cos)
         e2=vtors_three(mm+2,m)*(1.+x2cos)
         et=et+0.5*(1.-ef)*e1+(0.5+0.5*ef)*e2
         expo=exp(-phipi**2)/spi
         dij=dij-expo*e1- 0.5*(1.-ef)*vtors_three(mm+2,m)*x1sin*rn+ &
           &   expo*e2-(0.5+0.5*ef)*vtors_three(mm+2,m)*x2sin*rn
         mm=mm+3
      end do
!
!     sum up the torsional energy
!
      et=et*vtors_three(2,m)
!
!     the torsional gradient!
!
      dij=dij*vtors_three(2,m)*damp

      term1(1:3)=et*damp2ij*dampjk*dampkl*vab(1:3)
      term2(1:3)=et*damp2jk*dampij*dampkl*vcb(1:3)
      term3(1:3)=et*damp2kl*dampij*dampjk*vdc(1:3)

      g(1:3,i)=g(1:3,i)+dij*dda(1:3)+term1
      g(1:3,j)=g(1:3,j)+dij*ddb(1:3)-term1+term2
      g(1:3,k)=g(1:3,k)+dij*ddc(1:3)+term3-term2
      g(1:3,l)=g(1:3,l)+dij*ddd(1:3)-term3
!
!     scale energy by damping factor
!
      e=e+et*damp
!----------------------------------------------------
!     torsions for inversions!
!----------------------------------------------------
   else
!
!     do basically the same as above...
!
      vab(1:3) = xyz(1:3,j)-xyz(1:3,i)
      vcb(1:3) = xyz(1:3,j)-xyz(1:3,k)
      vdc(1:3) = xyz(1:3,j)-xyz(1:3,l)
      rij = vab(1)*vab(1) + vab(2)*vab(2) + vab(3)*vab(3)
      rjk = vcb(1)*vcb(1) + vcb(2)*vcb(2) + vcb(3)*vcb(3)
      rjl = vdc(1)*vdc(1) + vdc(2)*vdc(2) + vdc(3)*vdc(3)
      call abdamp(at(i),at(j),rij,dampij,damp2ij)
      call abdamp(at(k),at(j),rjk,dampjk,damp2jk)
      call abdamp(at(j),at(l),rjl,dampjl,damp2jl)
      damp= dampjk*dampij*dampjl

      phi=omega(n,xyz,i,j,k,l)
      call domegadr(n,xyz,i,j,k,l,phi,dda,ddb,ddc,ddd)

      rn=vtors_three(3,m)
      if (rn.gt.1.d-6)then
         dphi1=phi-phi0
         c1=dphi1+pi
         x1cos=cos(c1)
         x1sin=sin(c1)
         et   =(1.+x1cos)*vtors_three(2,m)
         dij  =-x1sin*vtors_three(2,m)*damp
      else
         et =   vtors_three(2,m)*(cos(phi) -cos(phi0))**2
         dij=2.*vtors_three(2,m)* sin(phi)*(cos(phi0)-cos(phi))*damp
      end if

      term1(1:3)=et*damp2ij*dampjk*dampjl*vab(1:3)
      term2(1:3)=et*damp2jk*dampij*dampjl*vcb(1:3)
      term3(1:3)=et*damp2jl*dampij*dampjk*vdc(1:3)

      g(1:3,i)=g(1:3,i)+dij*dda(1:3)-term1
      g(1:3,j)=g(1:3,j)+dij*ddb(1:3)+term1+term2+term3
      g(1:3,k)=g(1:3,k)+dij*ddc(1:3)-term2
      g(1:3,l)=g(1:3,l)+dij*ddd(1:3)-term3
      e=e+et*damp
   end if
end do

!
!     here restraints can be added!
!     maybe some metal surface could be simulated using restraints???
!
!      call egrestrain(n,xyz,g,er)
!      e = e + er
!

return
end subroutine ff_eg_three