module synthModule
use globalModule, only : OPA, PH, PC, PK, PHK, UMA, EV_ERG, SQRTPI, LARMOR, atmosphereType, lineListType, transitionType, &
	configType, myrank, CHEquilibrium, CHPartitionT, CHPartitionU
use atomicPartitionModule, only : partitionAtomic
use mathsModule, only : saha, vecfvoigt2, calculateDamping, planckFrequency, shortCharacteristics, computeHeight, gasPressure, vecfvoigt2, &
	vecfvoigt_zeeman, vecfvoigt_zeeman2, strength_zeeman, formal_sol_polarized, linInterpol
use backgroundOpacityModule, only : backgroundOpacity
use chemicalModule, only : getAbundance
implicit none
contains

!-----------------------------------------------------------------
! Fill the strength and splitting variables of the atomic_transition structure
!-----------------------------------------------------------------
	subroutine generateAtomicZeemanComponents(transition)
	type(transitionType) :: transition
	integer :: i, n, nlow, nup, iup, ilow, i_pi, i_red, i_blue, cual
	real(kind=8) :: Mup, Mlow, strength

		nup = 2*transition%Ju+1
		nlow = 2*transition%Jl+1

		i_pi = 0
		i_blue = 0
		i_red = 0

! First count the number of components of each type (
		transition%nComponents = 0
		do iup = 1, nup
			Mup = transition%Ju + 1 - iup  ! Mup=J...-J
			do ilow = 1, 3
				Mlow = Mup-2+ilow			! Mlow=Mup-1,Mup,Mup+1 (the allowed transitions)
				if (abs(Mlow) <= transition%Jl) then
					transition%nComponents(ilow) = transition%nComponents(ilow)+1
				endif
			enddo
		enddo

		allocate(transition%splitting(3,maxval(transition%nComponents)))
		allocate(transition%strength(3,maxval(transition%nComponents)))

! Now generate all the data
		do iup = 1, nup
			Mup = transition%Ju + 1 - iup  ! Mup=J...-J
			do ilow = 1, 3
				Mlow = Mup-2+ilow			! Mlow=Mup-1,Mup,Mup+1 (the allowed transitions)
				if (abs(Mlow) <= transition%Jl) then
					if (ilow == 1) then
						i_blue = i_blue + 1
						cual = i_blue
					endif
					if (ilow == 2) then
						i_pi = i_pi + 1
						cual = i_pi
					endif
					if (ilow == 3) then
						i_red = i_red + 1
						cual = i_red
					endif

					transition%strength(ilow,cual) = strength_zeeman(transition%Ju,transition%Jl,Mup,Mlow)
					transition%splitting(ilow,cual) = (transition%gu*Mup - transition%gl*Mlow)

				endif
			enddo
		enddo

	end subroutine generateAtomicZeemanComponents

!-----------------------------------------------------------------
! Return the seven independent elements of the absorption matrix
! Remember that, zeeman_voigt(q,:) and zeeman_faraday(q,:) have
!  q=1  Mlow=Mup-1  (sigma blue)
!  q=2  Mlow=Mup    (sigma pi)
!  q=3  Mlow=Mup+1  (sigma red)
!-----------------------------------------------------------------
	subroutine zeeman_opacity(transition, atmos, frequency)
	real(kind=8) :: frequency
	type(atmosphereType) :: atmos
	type(transitionType) :: transition
	integer :: n, nlow, nup, iup, ilow, i_pi, i_blue, i_red, cual
	real(kind=8) :: Mup, Mlow, strength

		nup = 2*transition%Ju+1
		nlow = 2*transition%Jl+1

		atmos%zeeman_voigt = 0.d0
		atmos%zeeman_faraday = 0.d0

		i_red = 0
		i_pi = 0
		i_blue = 0

		do iup = 1, nup
			Mup = transition%Ju + 1 - iup  ! Mup=J...-J
			do ilow = 1, 3
				Mlow = Mup-2+ilow			! Mlow=Mup-1,Mup,Mup+1 (the allowed transitions)
				if (abs(Mlow) <= transition%Jl) then

					if (ilow == 1) then
						i_blue = i_blue + 1
						cual = i_blue
					endif
					if (ilow == 2) then
						i_pi = i_pi + 1
						cual = i_pi
					endif
					if (ilow == 3) then
						i_red = i_red + 1
						cual = i_red
					endif

					atmos%splitting = LARMOR * atmos%B * transition%splitting(ilow,cual)

 					atmos%profile = vecfvoigt_zeeman2(transition%damping, (transition%frequency0 - frequency - transition%frequency0 * atmos%vmac / PC + atmos%splitting) / transition%deltaNu)

					atmos%zeeman_voigt(ilow,:) = atmos%zeeman_voigt(ilow,:) + transition%strength(ilow,cual) * atmos%profile(1,:)
					atmos%zeeman_faraday(ilow,:) = atmos%zeeman_faraday(ilow,:) + transition%strength(ilow,cual) * atmos%profile(2,:)

				endif
			enddo
		enddo

! Classical absorption coefficients
		atmos%coefficients(1,:) = 0.5d0 * (atmos%zeeman_voigt(2,:)*sin(atmos%thetaB)**2 + &
			0.5d0*(atmos%zeeman_voigt(1,:)+atmos%zeeman_voigt(3,:))*(1.d0+cos(atmos%thetaB)**2))  ! eta_I
 		atmos%coefficients(2,:) = 0.5d0 * (atmos%zeeman_voigt(2,:) - &
 			0.5d0*(atmos%zeeman_voigt(1,:)+atmos%zeeman_voigt(3,:))) * sin(atmos%thetaB)**2*cos(2.d0*atmos%chiB)  ! eta_Q
 		atmos%coefficients(3,:) = 0.5d0 * (atmos%zeeman_voigt(2,:) - &
 			0.5d0*(atmos%zeeman_voigt(1,:)+atmos%zeeman_voigt(3,:))) * sin(atmos%thetaB)**2*sin(2.d0*atmos%chiB)  ! eta_U
 		atmos%coefficients(4,:) = 0.5d0 * (atmos%zeeman_voigt(3,:)-atmos%zeeman_voigt(1,:)) * cos(atmos%thetaB)         ! eta_V
!
! ! Magneto-optical coefficients
 		atmos%coefficients(5,:) = 0.5d0 * (atmos%zeeman_faraday(2,:) - &
 			0.5d0*(atmos%zeeman_faraday(1,:)+atmos%zeeman_faraday(3,:))) * sin(atmos%thetaB)**2*cos(2.d0*atmos%chiB)  ! rho_Q
 		atmos%coefficients(6,:) = 0.5d0 * (atmos%zeeman_faraday(2,:) - &
 			0.5d0*(atmos%zeeman_faraday(1,:)+atmos%zeeman_faraday(3,:))) * sin(atmos%thetaB)**2*sin(2.d0*atmos%chiB)  ! rho_U
 		atmos%coefficients(7,:) = 0.5d0 * (atmos%zeeman_faraday(3,:)-atmos%zeeman_faraday(1,:)) * cos(atmos%thetaB)  ! rho_V

	end subroutine zeeman_opacity

!------------------------------------------------
! Synthesize all lines in a region for Stokes I, Q, U and V
!------------------------------------------------
	subroutine synthLinesZeeman(atmosphere, lineList, chunkIndex)
	type(atmosphereType) :: atmosphere
	type(lineListType) :: lineList
	real(kind=8) :: n1overn0, n2overn1, ei1, ei2, weight, abundance
	real(kind=8), allocatable :: voigtProfile(:)
	integer :: i, j, loop, fromLambda, toLambda, k, chunkIndex

		fromLambda = 1
		loop = 1

		lineList%opacity = 0.d0
		lineList%opacityContinuum = 0.d0
		lineList%boundary = 0.d0
		lineList%source = 0.d0

! Evaluate continuum opacity at the central wavelengths of the lines and then use linear interpolation
		do j = 1, atmosphere%nDepths
			do k = 1, lineList%nLines
				lineList%lambdaForInterpolation(k) = lineList%transition(k)%lambda0
				lineList%contOpacityForInterpolation(k) = backgroundOpacity(atmosphere%T(j), atmosphere%Pe(j), atmosphere%PH(j), atmosphere%PHminus(j), &
					atmosphere%PHplus(j), atmosphere%PH2(j), atmosphere%PH2plus(j), lineList%transition(k)%lambda0)
			enddo
			call linInterpol(lineList%lambdaForInterpolation,lineList%contOpacityForInterpolation,lineList%lambda,lineList%opacityContinuum(j,:))
		enddo

		do i = 1, lineList%nLines

! Molecular line
			if (lineList%transition(i)%molecule) then

! Compute line opacity
				lineList%transition(i)%lineOpacity = OPA * lineList%transition(i)%gf / atmosphere%molecularPartition * dexp(-lineList%transition(i)%Elow / (PK * atmosphere%T)) *&
					(1.d0 - dexp(-PHK * lineList%transition(i)%frequency0 / atmosphere%T)) * atmosphere%molecularAbundance

			else
! Atomic line
				call partitionAtomic(atmosphere%T, lineList%transition(i)%element, atmosphere%u1, atmosphere%u2, &
					atmosphere%u3, ei1, ei2, weight, atmosphere%abundance)

				atmosphere%n1overn0 = saha(atmosphere%T, atmosphere%Pe, atmosphere%u1, atmosphere%u2, ei1)
				atmosphere%n2overn1 = saha(atmosphere%T, atmosphere%Pe, atmosphere%u2, atmosphere%u3, ei2)
				atmosphere%niovern = 1.d0 / (1.d0 + atmosphere%n1overn0 + atmosphere%n2overn1 * atmosphere%n1overn0)

				select case (lineList%transition(i)%ionization)
					case(1)
						atmosphere%ui = atmosphere%u1
					case(2)
						atmosphere%ui = atmosphere%u2
					case(3)
						atmosphere%ui = atmosphere%u3
				end select

! Compute line opacity
				lineList%transition(i)%lineOpacity = OPA * lineList%transition(i)%gf / atmosphere%ui * dexp(-lineList%transition(i)%Elow / (PK * atmosphere%T)) *&
					(1.d0 - dexp(-PHK * lineList%transition(i)%frequency0 / atmosphere%T)) * atmosphere%niovern * &
					(atmosphere%nhtot * atmosphere%abundance)
			endif

! Doppler width
			lineList%transition(i)%dopplerWidth = dsqrt(2.d0 * PK * atmosphere%T / (lineList%transition(i)%mass * UMA))
			lineList%transition(i)%deltaNu = lineList%transition(i)%dopplerWidth * lineList%transition(i)%frequency0 / PC

! Compute the damping
			lineList%transition(i)%damping = calculateDamping(atmosphere%T, atmosphere%nHtot, atmosphere%Pe, atmosphere%PTotal, &
				lineList%transition(i)%dopplerWidth, ei1, lineList%transition(i)%Elow / EV_ERG, 0.d0, 0.d0, 0.d0, lineList%transition(i)%lambda0, &
				lineList%transition(i)%alphaABO, lineList%transition(i)%sigmaABO, lineList%transition(i)%mass)

! Add to total opacity in the region
			do j = 1, lineList%nLambdaTotal
				call zeeman_opacity(lineList%transition(i), atmosphere, lineList%frequency(j))
				do k = 1, 7
 					lineList%opacity(k,:,j) = lineList%opacity(k,:,j) + lineList%transition(i)%lineOpacity * atmosphere%coefficients(k,:) / (lineList%transition(i)%deltaNu * SQRTPI)
				enddo
				lineList%source(:,j) = planckFrequency(lineList%frequency(j), atmosphere%T)
				lineList%boundary(1,j) = lineList%source(1,j)
			enddo

		enddo

! Add continuum opacity
		lineList%opacity(1,:,:) = lineList%opacity(1,:,:) + lineList%opacityContinuum

! Solve RT equation
		do i = 1, lineList%nLambdaTotal
			lineList%stokesOut(chunkIndex,:,i) = formal_sol_polarized(atmosphere%height, lineList%opacity(:,:,i), lineList%source(:,i), 1.d0, lineList%boundary(:,i), 1)
		enddo

	end subroutine synthLinesZeeman

!------------------------------------------------
! Compute molecular abundance
!------------------------------------------------
	subroutine molecularAbundance(molCode, atmosphere)
	integer :: molCode
	type(atmosphereType) :: atmosphere
	real(kind=8) ::  ei1, ei2, weight, abundance
	integer :: i

! CH
		if (molCode == 102) then

! Hydrogen
			call partitionAtomic(atmosphere%T, 1, atmosphere%u1, atmosphere%u2, atmosphere%u3, ei1, ei2, weight, abundance)
			atmosphere%n1overn0 = saha(atmosphere%T, atmosphere%Pe, atmosphere%u1, atmosphere%u2, ei1)
			atmosphere%n2overn1 = saha(atmosphere%T, atmosphere%Pe, atmosphere%u2, atmosphere%u3, ei2)
			atmosphere%molecularAbundance = atmosphere%nhtot * abundance / (1.d0 + atmosphere%n1overn0 + atmosphere%n2overn1 * atmosphere%n1overn0)

! Carbon
			call partitionAtomic(atmosphere%T, 6, atmosphere%u1, atmosphere%u2, atmosphere%u3, ei1, ei2, weight, abundance)
			atmosphere%n1overn0 = saha(atmosphere%T, atmosphere%Pe, atmosphere%u1, atmosphere%u2, ei1)
			atmosphere%n2overn1 = saha(atmosphere%T, atmosphere%Pe, atmosphere%u2, atmosphere%u3, ei2)
			atmosphere%molecularAbundance = atmosphere%molecularAbundance * atmosphere%nhtot * abundance / (1.d0 + atmosphere%n1overn0 + atmosphere%n2overn1 * atmosphere%n1overn0)

			atmosphere%molecularAbundance = atmosphere%molecularAbundance * PK * atmosphere%T / atmosphere%molecularEquilibrium

		endif

	end subroutine molecularAbundance

!------------------------------------------------
! Synthesize all lines in a region for Stokes I
!------------------------------------------------
	subroutine synthLines(atmosphere, lineList, chunkIndex)
	type(atmosphereType) :: atmosphere
	type(lineListType) :: lineList
	real(kind=8) :: n1overn0, n2overn1, ei1, ei2, weight, abundance
	real(kind=8), allocatable :: voigtProfile(:)
	integer :: i, j, loop, fromLambda, toLambda, k, chunkIndex

		fromLambda = 1
		loop = 1

		lineList%opacity = 0.d0
		lineList%opacityContinuum = 0.d0
		lineList%boundary = 0.d0
		lineList%source = 0.d0

! Evaluate continuum opacity at the central wavelengths of the lines and then use linear interpolation
		do j = 1, atmosphere%nDepths
			do k = 1, lineList%nLines
				lineList%lambdaForInterpolation(k) = lineList%transition(k)%lambda0
				lineList%contOpacityForInterpolation(k) = backgroundOpacity(atmosphere%T(j), atmosphere%Pe(j), atmosphere%PH(j), atmosphere%PHminus(j), &
					atmosphere%PHplus(j), atmosphere%PH2(j), atmosphere%PH2plus(j), lineList%transition(k)%lambda0)
			enddo
			call linInterpol(lineList%lambdaForInterpolation,lineList%contOpacityForInterpolation,lineList%lambda,lineList%opacityContinuum(j,:))
		enddo

		do i = 1, lineList%nLines

! Molecular line
			if (lineList%transition(i)%molecule) then

! Compute line opacity
				lineList%transition(i)%lineOpacity = OPA * lineList%transition(i)%gf / atmosphere%molecularPartition * dexp(-lineList%transition(i)%Elow / (PK * atmosphere%T)) *&
					(1.d0 - dexp(-PHK * lineList%transition(i)%frequency0 / atmosphere%T)) * atmosphere%molecularAbundance

			else
! Atomic line
				call partitionAtomic(atmosphere%T, lineList%transition(i)%element, atmosphere%u1, atmosphere%u2, &
					atmosphere%u3, ei1, ei2, weight, atmosphere%abundance)

				atmosphere%n1overn0 = saha(atmosphere%T, atmosphere%Pe, atmosphere%u1, atmosphere%u2, ei1)
				atmosphere%n2overn1 = saha(atmosphere%T, atmosphere%Pe, atmosphere%u2, atmosphere%u3, ei2)
				atmosphere%niovern = 1.d0 / (1.d0 + atmosphere%n1overn0 + atmosphere%n2overn1 * atmosphere%n1overn0)

				select case (lineList%transition(i)%ionization)
					case(1)
						atmosphere%ui = atmosphere%u1
					case(2)
						atmosphere%ui = atmosphere%u2
					case(3)
						atmosphere%ui = atmosphere%u3
				end select
! Compute line opacity
				lineList%transition(i)%lineOpacity = OPA * lineList%transition(i)%gf / atmosphere%ui * dexp(-lineList%transition(i)%Elow / (PK * atmosphere%T)) *&
					(1.d0 - dexp(-PHK * lineList%transition(i)%frequency0 / atmosphere%T)) * atmosphere%niovern * &
					(atmosphere%nhtot * atmosphere%abundance)

			endif

! Doppler width
			lineList%transition(i)%dopplerWidth = dsqrt(2.d0 * PK * atmosphere%T / (lineList%transition(i)%mass * UMA))
			lineList%transition(i)%deltaNu = lineList%transition(i)%dopplerWidth * lineList%transition(i)%frequency0 / PC

! Compute the damping
			lineList%transition(i)%damping = calculateDamping(atmosphere%T, atmosphere%nHtot, atmosphere%Pe, atmosphere%PTotal, &
				lineList%transition(i)%dopplerWidth, ei1, lineList%transition(i)%Elow / EV_ERG, 0.d0, 0.d0, 0.d0, lineList%transition(i)%lambda0, &
				lineList%transition(i)%alphaABO, lineList%transition(i)%sigmaABO, lineList%transition(i)%mass)

! Add to total opacity in the region
			do j = 1, lineList%nLambdaTotal
				atmosphere%coefficients(1,:) = vecfvoigt2(lineList%transition(i)%damping, (lineList%transition(i)%frequency0 - lineList%frequency(j) - &
					lineList%transition(i)%frequency0 * atmosphere%vmac / PC) / lineList%transition(i)%deltaNu)
				lineList%opacity(1,:,j) = lineList%opacity(1,:,j) + lineList%transition(i)%lineOpacity * atmosphere%coefficients(1,:) / (lineList%transition(i)%deltaNu * SQRTPI)
				lineList%source(:,j) = planckFrequency(lineList%frequency(j), atmosphere%T)
				lineList%boundary(1,j) = lineList%source(1,j)
			enddo

		enddo

! Add continuum opacity
		lineList%opacity(1,:,:) = lineList%opacity(1,:,:) + lineList%opacityContinuum

! Solve RT equation
		lineList%stokesOut(chunkIndex,1,:) = shortCharacteristics(atmosphere%height, lineList%opacity(1,:,:), lineList%source, 1.d0, lineList%boundary(1,:), 1)

	end subroutine synthLines

!------------------------------------------------
! Synthesize all regions
!------------------------------------------------
	subroutine synthAllRegionsAndPixels(config, atmosphere, lineList)
	type(configType) :: config
	type(atmosphereType) :: atmosphere
	type(lineListType) :: lineList(:)
	integer :: i, j, k

		! atmosphere%modelsInChunk = 10
		do i = 1, atmosphere%modelsInChunk
			atmosphere%T = atmosphere%TChunk(:,i)
			atmosphere%vmac = atmosphere%vmacChunk(:,i)
			atmosphere%B = atmosphere%BChunk(:,i)
			atmosphere%thetaB = atmosphere%thetaBChunk(:,i)
			atmosphere%chiB = atmosphere%chiBChunk(:,i)
			atmosphere%Pe = atmosphere%PeChunk(:,i)

! Compute the chemical equilibrium
			if (config%chemicalEquilibriumOption == 1) then

				call getAbundance(9, atmosphere%nDepths, atmosphere%T, atmosphere%Pe, atmosphere%PH, atmosphere%PHminus, atmosphere%PHplus, &
						atmosphere%PH2, atmosphere%PH2plus, atmosphere%PTotal, atmosphere%molecularAbundance)
! Total hydrogen density
				atmosphere%nhtot = (atmosphere%PH + atmosphere%PHminus + atmosphere%PHplus + atmosphere%PH2 + atmosphere%PH2plus) / (PK * atmosphere%T)
			else

				call gasPressure(atmosphere%Pe, atmosphere%T, atmosphere%PH, atmosphere%PHminus, atmosphere%PHplus, atmosphere%PH2, atmosphere%PH2plus, atmosphere%PTotal)

! CH equilibrium constant
				atmosphere%molecularEquilibrium = 0.d0
				do k = 0, 8
					atmosphere%molecularEquilibrium = atmosphere%molecularEquilibrium + CHEquilibrium(k+1) * (dlog10(5040.d0 / atmosphere%T))**k
				enddo

! Transform the units from SI to cgs multipliying by 10 the necessary times depending on the
! units of the equilibrium constant
				atmosphere%molecularEquilibrium = 10.d0**atmosphere%molecularEquilibrium * 10.d0

! Total hydrogen density
				atmosphere%nhtot = (atmosphere%PH + atmosphere%PHminus + atmosphere%PHplus + atmosphere%PH2 + atmosphere%PH2plus) / (PK * atmosphere%T)

! Compute abundance
				call molecularAbundance(102, atmosphere)
			endif

! Compute partition function
			call linInterpol(CHPartitionT, CHPartitionU, atmosphere%T, atmosphere%molecularPartition)

! Generate height axis
			do k = 1, atmosphere%nDepths
				atmosphere%opacity500(k) = backgroundOpacity(atmosphere%T(k), atmosphere%Pe(k), atmosphere%PH(k), atmosphere%PHminus(k), &
					atmosphere%PHplus(k), atmosphere%PH2(k), atmosphere%PH2plus(k), 5000.d0)
			enddo

! Compute the height depth scale
			call computeHeight(atmosphere%lTau500, atmosphere%opacity500, atmosphere%height)

 			do j = 1, config%nRegions
 				if (config%zeemanSynthesis == 1) then
 					call synthLinesZeeman(atmosphere, lineList(j), i)
 				else
 					call synthLines(atmosphere, lineList(j), i)
 				endif
 			enddo
		enddo

	end subroutine synthAllRegionsAndPixels

end module synthModule


C-----------------------------------------------------------------------
      SUBROUTINE POLATES6(IPOPT,KGDSI,KGDSO,MI,MO,KM,IBI,LI,GI,
     &                    NO,RLAT,RLON,IBO,LO,GO,IRET)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:  POLATES6   INTERPOLATE SCALAR FIELDS (BUDGET)
C   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
C
C ABSTRACT: THIS SUBPROGRAM PERFORMS BUDGET INTERPOLATION
C           FROM ANY GRID TO ANY GRID FOR SCALAR FIELDS.
C           IT REQUIRES A GRID FOR THE OUTPUT FIELDS (KGDSO(1)>=0).
C           THE ALGORITHM SIMPLY COMPUTES (WEIGHTED) AVERAGES
C           OF NEIGHBOR POINTS ARRANGED IN A SQUARE BOX
C           CENTERED AROUND EACH OUTPUT GRID POINT AND STRETCHING
C           NEARLY HALFWAY TO EACH OF THE NEIGHBORING GRID POINTS.
C           OPTIONS ALLOW CHOICES OF NUMBER OF POINTS IN EACH RADIUS
C           FROM THE CENTER POINT (IPOPT(1)) WHICH DEFAULTS TO 2
C           (IF IPOPT(1)=-1) MEANING THAT 25 POINTS WILL BE AVERAGED;
C           FURTHER OPTIONS ARE THE RESPECTIVE WEIGHTS FOR THE RADIUS
C           POINTS STARTING AT THE CENTER POINT (IPOPT(2:2+IPOPT(1))
C           WHICH DEFAULTS TO ALL 1 (IF IPOPT(1)=-1 OR IPOPT(2)=-1).
C           ANOTHER OPTION IS THE MINIMUM PERCENTAGE FOR MASK,
C           I.E. PERCENT VALID INPUT DATA REQUIRED TO MAKE OUTPUT DATA,
C           (IPOPT(3+IPOPT(1)) WHICH DEFAULTS TO 50 (IF -1).
C           ONLY HORIZONTAL INTERPOLATION IS PERFORMED.
C           THE GRIDS ARE DEFINED BY THEIR GRID DESCRIPTION SECTIONS
C           (PASSED IN INTEGER FORM AS DECODED BY SUBPROGRAM W3FI63).
C           THE CURRENT CODE RECOGNIZES THE FOLLOWING PROJECTIONS:
C             (KGDS(1)=000) EQUIDISTANT CYLINDRICAL
C             (KGDS(1)=001) MERCATOR CYLINDRICAL
C             (KGDS(1)=003) LAMBERT CONFORMAL CONICAL
C             (KGDS(1)=004) GAUSSIAN CYLINDRICAL (SPECTRAL NATIVE)
C             (KGDS(1)=005) POLAR STEREOGRAPHIC AZIMUTHAL
C             (KGDS(1)=202) ROTATED EQUIDISTANT CYLINDRICAL (ETA NATIVE)
C           WHERE KGDS COULD BE EITHER INPUT KGDSI OR OUTPUT KGDSO.
C           AS AN ADDED BONUS THE NUMBER OF OUTPUT GRID POINTS
C           AND THEIR LATITUDES AND LONGITUDES ARE ALSO RETURNED.
C           INPUT BITMAPS WILL BE INTERPOLATED TO OUTPUT BITMAPS.
C           OUTPUT BITMAPS WILL ALSO BE CREATED WHEN THE OUTPUT GRID
C           EXTENDS OUTSIDE OF THE DOMAIN OF THE INPUT GRID.
C           THE OUTPUT FIELD IS SET TO 0 WHERE THE OUTPUT BITMAP IS OFF.
C
C PROGRAM HISTORY LOG:
C   96-04-10  IREDELL
C   96-10-04  IREDELL  NEIGHBOR POINTS NOT BILINEAR INTERPOLATION
C 1999-04-08  IREDELL  SPLIT IJKGDS INTO TWO PIECES
C 2001-06-18  IREDELL  INCLUDE MINIMUM MASK PERCENTAGE OPTION
C
C USAGE:    CALL POLATES6(IPOPT,KGDSI,KGDSO,MI,MO,KM,IBI,LI,GI,
C    &                    NO,RLAT,RLON,IBO,LO,GO,IRET)
C
C   INPUT ARGUMENT LIST:
C     IPOPT    - INTEGER (20) INTERPOLATION OPTIONS
C                IPOPT(1) IS NUMBER OF RADIUS POINTS
C                (DEFAULTS TO 2 IF IPOPT(1)=-1);
C                IPOPT(2:2+IPOPT(1)) ARE RESPECTIVE WEIGHTS
C                (DEFAULTS TO ALL 1 IF IPOPT(1)=-1 OR IPOPT(2)=-1).
C                IPOPT(3+IPOPT(1)) IS MINIMUM PERCENTAGE FOR MASK
C                (DEFAULTS TO 50 IF IPOPT(3+IPOPT(1)=-1)
C     KGDSI    - INTEGER (200) INPUT GDS PARAMETERS AS DECODED BY W3FI63
C     KGDSO    - INTEGER (200) OUTPUT GDS PARAMETERS
C     MI       - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS IF KM>1
C                OR DIMENSION OF INPUT GRID FIELDS IF KM=1
C     MO       - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS IF KM>1
C                OR DIMENSION OF OUTPUT GRID FIELDS IF KM=1
C     KM       - INTEGER NUMBER OF FIELDS TO INTERPOLATE
C     IBI      - INTEGER (KM) INPUT BITMAP FLAGS
C     LI       - LOGICAL*1 (MI,KM) INPUT BITMAPS (IF SOME IBI(K)=1)
C     GI       - REAL (MI,KM) INPUT FIELDS TO INTERPOLATE
C
C   OUTPUT ARGUMENT LIST:
C     NO       - INTEGER NUMBER OF OUTPUT POINTS
C     RLAT     - REAL (MO) OUTPUT LATITUDES IN DEGREES
C     RLON     - REAL (MO) OUTPUT LONGITUDES IN DEGREES
C     IBO      - INTEGER (KM) OUTPUT BITMAP FLAGS
C     LO       - LOGICAL*1 (MO,KM) OUTPUT BITMAPS (ALWAYS OUTPUT)
C     GO       - REAL (MO,KM) OUTPUT FIELDS INTERPOLATED
C     IRET     - INTEGER RETURN CODE
C                0    SUCCESSFUL INTERPOLATION
C                2    UNRECOGNIZED INPUT GRID OR NO GRID OVERLAP
C                3    UNRECOGNIZED OUTPUT GRID
C                31   INVALID UNDEFINED OUTPUT GRID
C                32   INVALID BUDGET METHOD PARAMETERS
C
C SUBPROGRAMS CALLED:
C   GDSWIZ       GRID DESCRIPTION SECTION WIZARD
C   IJKGDS0      SET UP PARAMETERS FOR IJKGDS1
C   (IJKGDS1)    RETURN FIELD POSITION FOR A GIVEN GRID POINT
C   POLFIXS      MAKE MULTIPLE POLE SCALAR VALUES CONSISTENT
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C
C$$$
CFPP$ EXPAND(IJKGDS1)
C
      IMPLICIT NONE
C
      INTEGER,    INTENT(IN   ) :: IBI(KM), IPOPT(20), KM, MI, MO
      INTEGER,    INTENT(IN   ) :: KGDSI(200), KGDSO(200)
      INTEGER,    INTENT(  OUT) :: IBO(KM), IRET, NO
C
      LOGICAL*1,  INTENT(IN   ) :: LI(MI,KM)
      LOGICAL*1,  INTENT(  OUT) :: LO(MO,KM)
C
      REAL,       INTENT(IN   ) :: GI(MI,KM)
      REAL,       INTENT(  OUT) :: GO(MO,KM), RLAT(MO), RLON(MO)
C
      REAL,       PARAMETER     :: FILL=-9999.
C
      INTEGER                   :: IB, I1, IJKGDS1, IJKGDSA(20)
      INTEGER                   :: JB, J1, K, LB, LSW, MP, N
      INTEGER                   :: N11(MO), NB, NB1, NB2, NB3, NB4, NV
C
      REAL,       ALLOCATABLE   :: CROT(:),SROT(:)
      REAL                      :: PMP,RLOB(MO),RLAB(MO)
      REAL                      :: WB, WO(MO,KM), XI, YI
      REAL                      :: XPTB(MO),YPTB(MO),XPTS(MO),YPTS(MO)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES.
      IRET=0
      IF(KGDSO(1).GE.0) THEN
        ALLOCATE(CROT(MO))
        ALLOCATE(SROT(MO))
        CALL GDSWIZ(KGDSO, 0,MO,FILL,XPTS,YPTS,RLON,RLAT,NO,0,
     &              CROT,SROT)
        DEALLOCATE(CROT,SROT)
        IF(NO.EQ.0) IRET=3
      ELSE
        IRET=31
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  SET PARAMETERS
      NB1=IPOPT(1)
      IF(NB1.EQ.-1) NB1=2
      IF(IRET.EQ.0.AND.NB1.LT.0) IRET=32
      LSW=1
      IF(IPOPT(1).EQ.-1.OR.IPOPT(2).EQ.-1) LSW=0
      IF(IRET.EQ.0.AND.LSW.EQ.1.AND.NB1.GT.15) IRET=32
      MP=IPOPT(3+IPOPT(1))
      IF(MP.EQ.-1.OR.MP.EQ.0) MP=50
      IF(MP.LT.0.OR.MP.GT.100) IRET=32
      PMP=MP*0.01
      IF(IRET.EQ.0) THEN
        NB2=2*NB1+1
        NB3=NB2*NB2
        NB4=NB3
        IF(LSW.EQ.1) THEN
          NB4=IPOPT(2)
          DO IB=1,NB1
            NB4=NB4+8*IB*IPOPT(2+IB)
          ENDDO
        ENDIF
      ELSE
        NB2=0
        NB3=0
        NB4=0
      ENDIF
CMIC$ DO ALL AUTOSCOPE
      DO K=1,KM
        DO N=1,NO
          GO(N,K)=0.
          WO(N,K)=0.
        ENDDO
      ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  LOOP OVER SAMPLE POINTS IN OUTPUT GRID BOX
      CALL IJKGDS0(KGDSI,IJKGDSA)
      DO NB=1,NB3
C  LOCATE INPUT POINTS AND COMPUTE THEIR WEIGHTS
        JB=(NB-1)/NB2-NB1
        IB=NB-(JB+NB1)*NB2-NB1-1
        LB=MAX(ABS(IB),ABS(JB))
        WB=1
        IF(LSW.EQ.1) WB=IPOPT(2+LB)
        IF(WB.NE.0) THEN
          DO N=1,NO
            XPTB(N)=XPTS(N)+IB/REAL(NB2)
            YPTB(N)=YPTS(N)+JB/REAL(NB2)
          ENDDO
          ALLOCATE(CROT(NO))
          ALLOCATE(SROT(NO))
          CALL GDSWIZ(KGDSO, 1,NO,FILL,XPTB,YPTB,RLOB,RLAB,NV,0,
     &                CROT,SROT)
          CALL GDSWIZ(KGDSI,-1,NO,FILL,XPTB,YPTB,RLOB,RLAB,NV,0,
     &                CROT,SROT)
          DEALLOCATE(CROT,SROT)
          IF(IRET.EQ.0.AND.NV.EQ.0.AND.LB.EQ.0) IRET=2
          DO N=1,NO
            XI=XPTB(N)
            YI=YPTB(N)
            IF(XI.NE.FILL.AND.YI.NE.FILL) THEN
              I1=NINT(XI)
              J1=NINT(YI)
              N11(N)=IJKGDS1(I1,J1,IJKGDSA)
              ELSE
                N11(N)=0
              ENDIF
          ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  INTERPOLATE WITH OR WITHOUT BITMAPS
CMIC$ DO ALL AUTOSCOPE
          DO K=1,KM
            DO N=1,NO
              IF(N11(N).GT.0) THEN
                IF(IBI(K).EQ.0.OR.LI(N11(N),K)) THEN
                  GO(N,K)=GO(N,K)+WB*GI(N11(N),K)
                  WO(N,K)=WO(N,K)+WB
                ENDIF
              ENDIF
            ENDDO
          ENDDO
        ENDIF
      ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  COMPUTE OUTPUT BITMAPS AND FIELDS
CMIC$ DO ALL AUTOSCOPE
      DO K=1,KM
        IBO(K)=IBI(K)
        DO N=1,NO
          LO(N,K)=WO(N,K).GE.PMP*NB4
          IF(LO(N,K)) THEN
            GO(N,K)=GO(N,K)/WO(N,K)
          ELSE
            IBO(K)=1
            GO(N,K)=0.
          ENDIF
        ENDDO
      ENDDO
      IF(KGDSO(1).EQ.0) CALL POLFIXS(NO,MO,KM,RLAT,RLON,IBO,LO,GO)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END


module Constants
  ! Code identifiers
  character(len=6)      :: codename='UVAFME'
  character(len=4)      :: version_id='2012'

  ! Global constants
  real,    parameter    :: pi=4.0*atan(1.0)
  !  real,    parameter    :: deg2rad=pi/180.
  !KAH Temporary to match with old version
  real,    parameter    :: deg2rad=0.017453

  ! Characters and files
  integer, parameter    :: MAX_NLEN=30
  integer, parameter    :: MAX_FILE=132
  integer, parameter    :: MAX_LINE=256
  integer, parameter    :: MAX_LONG_LINE=1000
  integer, parameter    :: MAX_DIR =132
  integer, parameter    :: MAX_CHAR=80
  integer, parameter    :: MAX_FIELDS=100

  ! Standard for height measurements
  real, parameter       :: std_ht=1.3

  ! Unit conversions
  real, parameter       :: m_to_cm=100.0
  real, parameter       :: hec_to_m2=10000
  real, parameter       :: m2_to_hec=0.0001
  real, parameter       :: mm_to_cm=0.1

  ! Radiation constants
  ! Day length model parameters
  real, parameter       :: b=0.017214
  real, parameter       :: As=0.409
  real, parameter       :: Ac=0.033
  real, parameter       :: phase=-1.39
  ! Radiation latitude dependencies
  real, parameter       :: Amp=37.58603
  real, parameter       :: dl_omega=7.639437
  real, parameter       :: exrad_coef=0.0820

  ! Hargreaves evaporation constants
  real, parameter       :: H_coeff=0.000093876
  real, parameter       :: H_addon=17.8

  ! Climate related constants
  integer, parameter    ::  NTEMPS=12
  integer, parameter    ::  max_days_per_year=366
  integer, parameter    ::  days_per_year=365
  ! Precipitation nitrogen content
  real                  :: prcp_n=0.00002

  !  Global tree attributes
  !  Number of height categories
  integer, parameter   :: NHC=7
  !  Conifer leaf C/N ratio
  real                 :: con_leaf_c_n=60.0
  !  Deciduous leaf C/N ratio
  real                 :: dec_leaf_c_n=40.0
  !  Stem C/N ratio
  real                 :: stem_c_n=450.0
  !  Conifer to deciduous leaf area ratio ?
  real                 :: con_leaf_ratio=0.3

end module Constants


MODULE module_aer_opt_out

   REAL, PARAMETER, PRIVATE :: afwalowv1 = 3.
   REAL, PARAMETER, PRIVATE :: afwahiwv1 = 5.
   REAL, PARAMETER, PRIVATE :: afwalowv2 = 8.
   REAL, PARAMETER, PRIVATE :: afwahiwv2 = 12.
CONTAINS
   SUBROUTINE aer_opt_out(dz8w &
                   ,ext_coeff,bscat_coeff,asym_par &
                   ,tauaer300,tauaer400,tauaer600,tauaer999 &
                   ,gaer300,gaer400,gaer600,gaer999 &
                   ,waer300,waer400,waer600,waer999 &
                   ,num_ext_coef,num_bscat_coef,num_asym_par &
                   ,ids,ide, jds,jde, kds,kde &
                   ,ims,ime, jms,jme, kms,kme &
                   ,its,ite, jts,jte, kts,kte )
USE module_configure, only:p_extcof3,p_extcof55,p_extcof106,p_extcof3_5,p_extcof8_12,p_bscof3,p_bscof55, &
           p_bscof106,p_asympar3,p_asympar55,p_asympar106

   IMPLICIT NONE
   INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
                                       ims,ime, jms,jme, kms,kme, &
                                       its,ite, jts,jte, kts,kte, &
                                       num_ext_coef,num_bscat_coef,num_asym_par
   REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 1:num_ext_coef ), INTENT (OUT) :: ext_coeff
   REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 1:num_bscat_coef ), INTENT (OUT) :: bscat_coeff
   REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 1:num_asym_par ), INTENT (OUT) :: asym_par
   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
         INTENT(IN ) :: tauaer300,tauaer400,tauaer600,tauaer999, &
                                 gaer300,gaer400,gaer600,gaer999, &
                              waer300,waer400,waer600,waer999,dz8w
   real :: ang,slope,slopeg,slopessa,onemang
   integer :: i,j,k
      do j = jts,jte
      do k = kts,kte
      do i = its,ite
      ext_coeff(i,k,j,p_extcof3)=tauaer300(i,k,j)*1.E3/dz8w(i,k,j)
      bscat_coeff(i,k,j,p_bscof3)=tauaer300(i,k,j)*waer300(i,k,j)*1.E3/dz8w(i,k,j)
      asym_par(i,k,j,p_asympar3)=gaer300(i,k,j)
           ang=log(tauaer300(i,k,j)/tauaer999(i,k,j))/log(999./300.)
           slopessa=(waer600(i,k,j)-waer400(i,k,j))/.2
           slopeg=(gaer600(i,k,j)-gaer400(i,k,j))/.2
      ext_coeff(i,k,j,p_extcof55)=tauaer400(i,k,j)*1.E3*((0.4/0.55)**ang)/dz8w(i,k,j)
      slope= slopessa*(0.55-.6)+waer600(i,k,j)
      slope=AMIN1(1.0,AMAX1(0.4,slope))
      bscat_coeff(i,k,j,p_bscof55)=ext_coeff(i,k,j,p_extcof55)*slope
      asym_par(i,k,j,p_asympar55)=AMIN1(1.,AMAX1(0.5,slopeg*(.55-.6)+gaer600(i,k,j)))
           slopessa=(waer999(i,k,j)-waer600(i,k,j))/.399
           slopeg=(gaer999(i,k,j)-gaer600(i,k,j))/.399
      ext_coeff(i,k,j,p_extcof106)=tauaer400(i,k,j)*1.E3*((0.4/1.06)**ang)/dz8w(i,k,j)
      slope= slopessa*(1.06-.999)+waer999(i,k,j)
      slope=AMIN1(1.0,AMAX1(0.4,slope))
      bscat_coeff(i,k,j,p_bscof106)=ext_coeff(i,k,j,p_extcof106)*slope
      asym_par(i,k,j,p_asympar106)=AMIN1(1.,AMAX1(0.5,slopeg*(1.06-.999)+gaer600(i,k,j)))
      onemang=1.-ang
      if(abs(onemang).gt.1.E-3)then
      slope = tauaer400(i,k,j)*(0.4/afwalowv1)**ang
      slopeg = tauaer400(i,k,j)*(0.4/afwahiwv1)**ang
      ext_coeff(i,k,j,p_extcof3_5) = (slopeg*afwahiwv1-slope*afwalowv1)/(afwahiwv1-afwalowv1)/onemang
      slope = tauaer400(i,k,j)*(0.4/afwalowv2)**ang
      slopeg = tauaer400(i,k,j)*(0.4/afwahiwv2)**ang
      ext_coeff(i,k,j,p_extcof8_12) = (slopeg*afwahiwv2-slope*afwalowv2)/(afwahiwv2-afwalowv2)/onemang
      else
      ext_coeff(i,k,j,p_extcof3_5) = tauaer400(i,k,j)*0.4*log(afwahiwv1/afwalowv1)/(afwahiwv1-afwalowv1)
      ext_coeff(i,k,j,p_extcof8_12) = tauaer400(i,k,j)*0.4*log(afwahiwv2/afwalowv2)/(afwahiwv2-afwalowv2)
      endif
      ext_coeff(i,k,j,p_extcof3_5) = ext_coeff(i,k,j,p_extcof3_5)*1.E3/dz8w(i,k,j)
      ext_coeff(i,k,j,p_extcof8_12) = ext_coeff(i,k,j,p_extcof8_12)*1.E3/dz8w(i,k,j)
      end do
      end do
      end do
  END SUBROUTINE AER_OPT_OUT
END MODULE module_aer_opt_out


C    @(#)fxrxrt.f	20.3 2/13/96
        subroutine fxrxrt (y,v,tol)
        complex * 16 y(2,2),v(2)
        real tol
C
C       This subroutine changes the R/X ratio (or more precisely, the
C       G/B ratio) to accomodate the restrictions on the decoupled
C       solution routine.
c
c	Changed to accept double precision arguments.
C
C       "Acceptable" G/B values are:
C
C       1. CDABS (Y) .GT. TOL, and
C       2. Compensation occurs for G/B < -0.50 or G/B > 0.25.
C
C       Y (new) is computed such that V and A are preserved.  Fictitious
C       shunts are employed. If the branch admittance is less than TOL,
C       the branch is replaced entirely with shunt.
C
        complex * 16 a(2)
        double precision yb, yg, ratio
        integer i, j
C
C       Check G/B ratio of equivalent branches
C
        do i = 1,2
           a(i) = 0.0d0
           do j = 1,2
              a(i) = a(i) + y(i,j)*v(j)
           enddo
        enddo
        yb = dimag (y(1,2))
        yg = dreal (y(1,2))
        if (cdabs (y(1,2)) .le. tol) then
           y(1,2) = 0.0d0
           y(2,1) = 0.0d0
        else if (yb .ne. 0.0d0) then
           ratio = yg / yb
           if (ratio .le. -0.50d0 .or. ratio .ge. 0.25d0) then
              y(1,2) = dcmplx (0.0d0,yb)
              y(2,1) = y(1,2)
           endif
        else
           y(1,2) = dcmplx (0.0d0,yg)
           y(2,1) = y(1,2)
        endif
        y(1,1) = (a(1) - y(1,2)*v(2)) / v(1)
        y(2,2) = (a(2) - y(2,1)*v(1)) / v(2)
  120   continue
        return
        end


      MODULE m_vacudz
      CONTAINS
      SUBROUTINE vacudz(
     >     e,vz,vz0,nmz,dz,
     <     udz,dudz,ddnv,ue,
     >     duz,u)
c*********************************************************************
c     integrates the vacuum energy derivative wavefunction ue for the
c     energy e>0 using the schrodinger equation. the wavefunction u
c     is necessary (obtained from a previous call to vacuz). the
c     conventions are the same as in vacuz. ue will be orthogonal to
c     u. udz and dudz are the value and normal derivative at the
c     vacuum boundary.
c     based on code by m. weinert
c*********************************************************************
      use m_juDFT
      USE m_constants
      USE m_intgr, ONLY : intgz0
      IMPLICIT NONE
C     ..
C     .. Scalar Arguments ..
      INTEGER, INTENT (IN) :: nmz
      REAL,    INTENT (IN) :: duz,dz,e,vz0
      REAL,    INTENT (OUT):: ddnv,dudz,udz
C     ..
C     .. Array Arguments ..
      REAL, INTENT (IN) ::  u(nmz),vz(nmz)
      REAL, INTENT (OUT):: ue(nmz)
C     ..
C     .. Local Scalars ..
      REAL a,eru,erw,h,sk1,sk2,sk3,sk4,sl1,sl2,sl3,sl4,tnorm,u1,u10,
     +     u1p,vme,w1,w10,w1p,yn,zn,znm
      INTEGER i,it,n,n1
      LOGICAL tail
C     ..
C     .. Local Arrays ..
      REAL we(nmz),wp(nmz)
C     ..
C     .. Data statements ..
      REAL,PARAMETER:: eps=1.e-06
C     ..
      IF (e.GE.vz0)  CALL
     +     juDFT_error("e >= vz0",calledby ="vacudz",hint =
     +     'Vacuum energy-parameter too high')
c---  >    set up initial conditions
      znm = (nmz-1)*dz
      a = sqrt(2.* (vz0-e))
      ue(nmz) = (a*znm-0.5)*u(nmz)/ (a*a)
      we(nmz) = (a*znm-1.5)*u(nmz)/a
      wp(nmz) = 2.* (vz(nmz)-e)*ue(nmz) - 2.*u(nmz)
c---  >    use 4nd order runge-kutta to first few mesh points
      h = dz
      DO  i = 1,4
         n = nmz + 1 - i
         yn = ue(n)
         zn = we(n)
         sk1 = h*zn
         sl1 = h*wp(n)
         sk2 = h* (zn+0.5*sl1)
         sl2 = h* ((vz(n)+vz(n-1)-e)* (yn+0.5*sk1)- (u(n)+u(n-1)))
         sk3 = h* (zn+0.5*sl2)
         sl3 = h* ((vz(n)+vz(n-1)-e)* (yn+0.5*sk2)- (u(n)+u(n-1)))
         sk4 = h* (zn+sl3)
         sl4 = h* (2.* (vz(n-1)-e)* (yn+sk3)-2.*u(n-1))
         ue(n-1) = yn + (sk1+2.*sk2+2.*sk3+sk4)/6.
         we(n-1) = zn + (sl1+2.*sl2+2.*sl3+sl4)/6.
         wp(n-1) = 2.* (vz(n-1)-e)*ue(n-1) - 2.*u(n-1)
      ENDDO
c---  >    use adams-bashforth-moulton predictor-corrector for rest
      DO i = 5,nmz - 1
c---  >    adams-bashforth predictor (order h**5)
         n = nmz + 1 - i
         n1 = n - 1
         u10 = ue(n) + h* (55.*we(n)-59.*we(n+1)+37.*we(n+2)-
     +        9.*we(n+3))/24.
         w10 = we(n) + h* (55.*wp(n)-59.*wp(n+1)+37.*wp(n+2)-
     +        9.*wp(n+3))/24.
c---  >    evaluate derivative at next point( n-1 corresponds to m+1)
         vme = 2.* (vz(n-1)-e)
         u1p = w10
         w1p = vme*u10 - 2.*u(n-1)
c---  >    adams-moulton correctors: (order h**6)
         DO  it = 1,10
            u1 = ue(n) + h* (251.*u1p+646.*we(n)-264.*we(n+1)+
     +           106.*we(n+2)-19.*we(n+3))/720.
            w1 = we(n) + h* (251.*w1p+646.*wp(n)-264.*wp(n+1)+
     +           106.*wp(n+2)-19.*wp(n+3))/720.
c---  >    final evaluation
            u1p = w1
            w1p = vme*u1 - 2.*u(n-1)
c---  >    test quality of corrector and iterate if necessary
            eru = abs(u1-u10)/ (abs(u1)+abs(h*u1p))
            erw = abs(w1-w10)/ (abs(w1)+abs(h*w1p))
            IF (eru.LT.eps .AND. erw.LT.eps) EXIT
            u10 = u1
            w10 = w1
         ENDDO
         IF (it>10) THEN
            WRITE (oUnit,FMT=8000) n1,eru,erw
 8000       FORMAT (' ***vacudz - step may be too big - mesh point',i5,
     +           ', eru,erw=',1p,2e16.7)
         ENDIF
c---  >    store values
         ue(n1) = u1
         we(n1) = w1
         wp(n1) = w1p
      ENDDO
c---  >    ensure orthogonality
      tail = .true.
      DO  i = 1,nmz
         wp(i) = ue(nmz+1-i)*u(nmz+1-i)
      ENDDO
      CALL intgz0(wp,dz,nmz,tnorm,tail)
      ue(:) = ue(:) - tnorm*u(:)
      udz = ue(1)
      dudz = we(1) - tnorm*duz
c---  >    determine normalization
      DO  i = 1,nmz
         wp(i) = ue(nmz+1-i)*ue(nmz+1-i)
      enddo
      CALL intgz0(wp,dz,nmz,ddnv,tail)
      RETURN
      END subroutine
      END


C CLSDP.F - Gateway function for Loop Shaping Design of
C           continuous-time systems using SLICOT routine
C           SB10ID.
C
C RELEASE 2.0 of SLICOT Robust Control Toolbox.
C Based on SLICOT RELEASE 5.7. Copyright (c) 2002-2020 NICONET e.V.
C
C Matlab call:
C   [AK,BK,CK,DK,(RCOND)] = clsdp(A,B,C,D,factor)
C
C Purpose:
C     To compute the matrices of the positive feedback controller
C
C              | Ak | Bk |
C          K = |----|----|
C              | Ck | Dk |
C
C     for the shaped plant
C
C              | A | B |
C          G = |---|---|
C              | C | D |
C
C     in the McFarlane/Glover Loop Shaping Design Procedure.
C
C Input parameters:
C   A      - the n-by-n system state matrix A.
C   B      - the n-by-m system input matrix B.
C   C      - the p-by-n system output matrix C.
C   D      - the p-by-m system matrix D.
C   factor - = 1 implies that an optimal controller is required
C            > 1 implies that a suboptimal controller is required
C                achieving a performance FACTOR less than optimal.
C
C Output parameters:
C   AK    - the nk-by-nk controller state matrix Ak.
C   BK    - the nk-by-np controller input matrix Bk.
C   CK    - the m-by-nk controller output matrix Ck.
C   DK    - the m-by-np controller matrix Dk.
C   RCOND - (optional) a vector containing estimates of the reciprocal
C           condition numbers of the Riccati equations which have to be
C           solved during the computation of the controller.
C           RCOND(1) contains an estimate of the reciprocal condition
C                    number of the X-Riccati equation,
C           RCOND(2) contains an estimate of the reciprocal condition
C                    number of the Z-Riccati equation.
C
C References
C   [1] D.W. Gu, P.Hr. Petkov, D.W. Gu and M.M. Konstantinov.
C       Hinf Loop Shaping Design procedure routines in SLICOT.
C       NICONET Report 1999-15, November 1999.
C
C Contributor:
C   P.Hr. Petkov, TU Sofia, Bulgaria, Oct. 2000.
C
C Revisions:
C   V. Sima, February 2001, Apr. 2009, Dec. 2012.
C
C **********************************************************************
C
C
      SUBROUTINE MEXFUNCTION( NLHS, PLHS, NRHS, PRHS )
C
C .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
C
C .. Mex-file interface parameters ..
      INTEGER           PLHS(*), PRHS(*)
      INTEGER*4         NLHS, NRHS
C
C .. Mex-file integer functions ..
      INTEGER           mxCreateDoubleMatrix, mxGetPr
      INTEGER*4         mxGetM, mxGetN, mxIsNumeric, mxIsComplex
C
C .. Scalar parameters used by SLICOT subroutines ..
      INTEGER           INFO, LDA, LDB, LDC, LDD, LDAK, LDBK, LDCK,
     $                  LDDK, LDWORK, M, N, NK, P
      DOUBLE PRECISION  FACTOR
C
C .. Allocatable arrays ..
C !Fortran 90/95 (Fixed dimensions should be used with Fortran 77.)
      INTEGER,          ALLOCATABLE :: IWORK(:)
      LOGICAL,          ALLOCATABLE :: BWORK(:)
      DOUBLE PRECISION, ALLOCATABLE :: A(:,:), B(:,:), C(:,:), D(:,:),
     $                  AK(:,:), BK(:,:), CK(:,:), DK(:,:),
     $                  AKA(:,:), BKA(:,:), CKA(:,:), DKA(:,:), DWORK(:)
C
C .. Local variables and constant dimension arrays ..
      CHARACTER*120     TEXT
      INTEGER           LBWORK, LIWORK
      DOUBLE PRECISION  RCOND(2)
C
C .. External subroutines ..
      EXTERNAL          SB10ID
C
C ..Intrinsic functions..
      INTRINSIC         MAX, MIN
C
C Check for proper number of arguments.
C
      IF ( NRHS.NE.5 ) THEN
         CALL mexErrMsgTxt
     $        ( 'CLSDP requires 5 input arguments' )
      ELSE IF ( NLHS.LT.4 ) THEN
         CALL mexErrMsgTxt
     $        ( 'CLSDP requires at least 4 output arguments' )
      END IF
C
C Check dimensions of input parameters and read/set scalar parameters.
C
C   A(nxn), B(nxm), C(pxn), D(pxm)
C
      N = mxGetM( PRHS(1) )
      M = mxGetN( PRHS(2) )
      P = mxGetM( PRHS(3) )
C
      IF ( mxGetN( PRHS(1) ).NE.N ) THEN
         CALL mexErrMsgTxt( 'A must be a square matrix' )
      END IF
      IF ( mxIsNumeric( PRHS(1) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(1) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'A must be a numeric matrix' )
      END IF
      IF ( mxGetM( PRHS(2) ).NE.N ) THEN
         CALL mexErrMsgTxt( 'B must have the same row dimension as A' )
      END IF
      IF ( mxIsNumeric( PRHS(2) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(2) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'B must be a numeric matrix' )
      END IF
      IF ( mxGetN( PRHS(3) ).NE.N ) THEN
         CALL mexErrMsgTxt
     $       ('C must have the same column dimension as A' )
      END IF
      IF ( mxIsNumeric( PRHS(3) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(3) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'C must be a numeric matrix' )
      END IF
      IF ( mxGetM( PRHS(4) ).NE.P ) THEN
         CALL mexErrMsgTxt( 'D must have the same row dimension as C' )
      END IF
      IF ( mxGetN( PRHS(4) ).NE.M ) THEN
         CALL mexErrMsgTxt
     $       ( 'D must have the same column dimension as B' )
      END IF
      IF ( mxIsNumeric( PRHS(4) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(4) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'D must be a numeric matrix' )
      END IF
      IF ( M.LE.0 ) THEN
         CALL mexErrMsgTxt( 'The system has no inputs' )
      END IF
      IF ( P.LE.0 ) THEN
         CALL mexErrMsgTxt( 'The system has no outputs' )
      END IF
C
C     factor
      IF ( mxGetM( PRHS(5) ).NE.1 .OR. mxGetN( PRHS(5) ).NE.1 ) THEN
          CALL mexErrMsgTxt( 'FACTOR must be a scalar' )
      END IF
      IF ( mxIsNumeric( PRHS(5) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(5) ).EQ.1 ) THEN
           CALL mexErrMsgTxt( 'FACTOR must be a numeric scalar' )
      END IF
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(5) ), FACTOR, 1 )
      IF ( FACTOR.LT.ONE ) THEN
          CALL mexErrMsgTxt( 'FACTOR must be equal or greater than 1' )
      END IF
C
C Determine the lenghts of working arrays.
C Use a larger value for LDWORK for enabling calls of block algorithms
C in DGEES.
C
      LDA = MAX( 1, N )
      LDB = MAX( 1, N )
      LDC = MAX( 1, P )
      LDD = MAX( 1, P )
      LDAK = MAX( 1, N )
      LDBK = MAX( 1, N )
      LDCK = MAX( 1, M )
      LDDK = MAX( 1, M )
      LBWORK = 2*N
      LIWORK = MAX ( 2*N, N*N, M, P )
      LDWORK = 4*N*N + M*M + P*P + 2*M*N + N*P + 4*N +
     $         MAX( 6*N*N + 5 + MAX( 1, 4*N*N + 8*N ), N*P + 2*N )
C
C Allocate variable dimension local arrays.
C !Fortran 90/95
C
      ALLOCATE ( A( LDA, N ), B( LDB, M ), C( LDC, N ), D( LDD, M ),
     $           AK( LDAK, N ), BK( LDBK, P ), CK( LDCK, N ),
     $           DK( LDDK, P ), AKA( LDAK, N ), BKA( LDBK, P ),
     $           CKA( LDCK, N ), DKA( LDDK, P ) )
      ALLOCATE ( BWORK( LBWORK ), IWORK( LIWORK ), DWORK( LDWORK ) )
C
C Copy inputs from MATLAB workspace to locally allocated arrays.
C
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(1) ), A, N*N )
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(2) ), B, N*M )
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(3) ), C, P*N )
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(4) ), D, P*M )
C
C Do the actual computations.
C
      CALL SB10ID( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, FACTOR,
     $             NK, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, RCOND,
     $             IWORK, DWORK, LDWORK, BWORK, INFO )
C
C Copy output which is stored in local array to matrix output
C
      CALL DLACPY( 'F', NK, NK, AK, LDAK, AKA, NK )
      CALL DLACPY( 'F', NK, P, BK, LDBK, BKA, NK )
      CALL DLACPY( 'F', M, NK, CK, LDCK, CKA, M )
      CALL DLACPY( 'F', M, P, DK, LDDK, DKA, M )
C
C Copy output to MATLAB workspace.
C
      PLHS(1) = mxCreateDoubleMatrix( NK, NK, 0 )
      CALL mxCopyReal8ToPtr( AKA, mxGetPr( PLHS(1) ), NK*NK )
      PLHS(2) = mxCreateDoubleMatrix( NK, P, 0 )
      CALL mxCopyReal8ToPtr( BKA, mxGetPr( PLHS(2) ), NK*P )
      PLHS(3) = mxCreateDoubleMatrix( M, NK, 0 )
      CALL mxCopyReal8ToPtr( CKA, mxGetPr( PLHS(3) ), M*NK )
      PLHS(4) = mxCreateDoubleMatrix( M, P, 0 )
      CALL mxCopyReal8ToPtr( DKA, mxGetPr( PLHS(4) ), M*P )
      IF ( NLHS.GT.4 ) THEN
         PLHS(5) = mxCreateDoubleMatrix( 2, 1, 0 )
         CALL mxCopyReal8ToPtr( RCOND, mxGetPr( PLHS(5) ), 2 )
      END IF
C
C Deallocate local arrays.
C !Fortran 90/95
C
      DEALLOCATE( A, B, C, D, AK, BK, CK, DK, AKA, BKA, CKA, DKA, BWORK,
     $            IWORK, DWORK )
C
C Error and warning handling.
C
      IF ( INFO.NE.0 ) THEN
          WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM SB10ID'')'
     $         ) INFO
      END IF
C
      IF ( INFO.NE.0 ) THEN
         CALL mexErrMsgTxt( TEXT )
      END IF
C
      RETURN
C *** Last line of CLSDP ***
      END


! ******************************************************************************************************************************** !
! atchem_box.f90
! Atmosphere Chemistry
! MISCELLANEOUS ROUTINES
! ******************************************************************************************************************************** !

MODULE atchem_box

  USE atchem_lib
  IMPLICIT NONE
  SAVE

CONTAINS

  ! ****************************************************************************************************************************** !
  ! EXCHANGE CARBON WITH A VIRTUAL TERRESTRIAL RESERVOIR
  SUBROUTINE sub_calc_terrCO2exchange(dum_i,dum_j,dum_dtyr,dum_fatm)
    IMPLICIT NONE
    ! dummy arguments
    INTEGER,INTENT(in)::dum_i,dum_j
    real,intent(in)::dum_dtyr
    REAL,DIMENSION(n_atm),intent(inout)::dum_fatm              ! net flux to atmosphere (mol)
    ! local variables
    real::loc_Fatm,loc_Fterr                                   ! flux to atm, flux to terrestrial biosphere
    real::loc_Ratm,loc_Rterr                                   ! local isotopic variables

    ! *** INITIALIZE LOCAL VARIABLES ***
    loc_Fatm  = dum_dtyr*par_atm_FterrCO2exchange/real(n_i*n_j)
    loc_Fterr = dum_dtyr*par_atm_FterrCO2exchange/real(n_i*n_j)
    loc_Ratm = atm(ia_pCO2_13C,dum_i,dum_j)/atm(ia_pCO2,dum_i,dum_j)
    loc_Rterr = atm_slabbiosphere(ia_pCO2_13C,dum_i,dum_j)/atm_slabbiosphere(ia_pCO2,dum_i,dum_j)

    ! *** EXCHANGE CO2 ***
    ! NOTE: atm_slabbiosphere in units of mol
    ! bulk CO2
    dum_fatm(ia_pCO2) = dum_fatm(ia_pCO2) + loc_Fatm - loc_Fterr
    atm_slabbiosphere(ia_pCO2,dum_i,dum_j) = &
         & atm_slabbiosphere(ia_pCO2,dum_i,dum_j) - loc_Fatm + loc_Fterr
    ! d13C
    dum_fatm(ia_pCO2_13C) = dum_fatm(ia_pCO2_13C) + loc_Rterr*loc_Fatm - loc_Ratm*loc_Fterr
    atm_slabbiosphere(ia_pCO2_13C,dum_i,dum_j) = &
         & atm_slabbiosphere(ia_pCO2_13C,dum_i,dum_j) - loc_Rterr*loc_Fatm + loc_Ratm*loc_Fterr

  END SUBROUTINE sub_calc_terrCO2exchange
  ! ****************************************************************************************************************************** !

  ! ****************************************************************************************************************************** !
  ! OXIDIZE CH4
  SUBROUTINE sub_calc_oxidize_CH4(dum_i,dum_j,dum_dtyr)
    IMPLICIT NONE
    ! dummy arguments
    INTEGER,INTENT(in)::dum_i,dum_j
    real,intent(in)::dum_dtyr
    ! local variables
    real::loc_tau
    real::loc_fracdecay
    real::loc_CH4

    ! *** CALCULATE LOCAL CONSTANTS ***
    ! atmospheric lifetime from Osborn and Wigley [1994]
    ! NOTE1: restrict lifetime calculation to 0.5*CH4(0) at the lower end (limit of calibration curve)
    ! NOTE2: strictly, calibratio curve ends at 4.0*CH4(0) in Osborn and Wigley [1994]
    ! NOTE3: omitting [OH], [NOx] etc etc
    loc_CH4 = atm(ia_pCH4,dum_i,dum_j)
    if (loc_CH4 < 0.5*const_pCH4_oxidation_C0) loc_CH4 = 0.5*const_pCH4_oxidation_C0
    loc_tau = const_pCH4_oxidation_tau0*(loc_CH4/const_pCH4_oxidation_C0)**const_pCH4_oxidation_N
    loc_fracdecay = dum_dtyr/loc_tau

    ! *** ATMOSPHERIC CH4->CO2 ***
    atm(ia_pO2,dum_i,dum_j)      = atm(ia_pO2,dum_i,dum_j)      - 2.0*loc_fracdecay*atm(ia_pCH4,dum_i,dum_j)
    atm(ia_pCO2,dum_i,dum_j)     = atm(ia_pCO2,dum_i,dum_j)     + loc_fracdecay*atm(ia_pCH4,dum_i,dum_j)
    atm(ia_pCO2_13C,dum_i,dum_j) = atm(ia_pCO2_13C,dum_i,dum_j) + loc_fracdecay*atm(ia_pCH4_13C,dum_i,dum_j)
    atm(ia_pCO2_14C,dum_i,dum_j) = atm(ia_pCO2_14C,dum_i,dum_j) + loc_fracdecay*atm(ia_pCH4_14C,dum_i,dum_j)
    atm(ia_pCH4,dum_i,dum_j)     = (1.0 - loc_fracdecay)*atm(ia_pCH4,dum_i,dum_j)
    atm(ia_pCH4_13C,dum_i,dum_j) = (1.0 - loc_fracdecay)*atm(ia_pCH4_13C,dum_i,dum_j)
    atm(ia_pCH4_14C,dum_i,dum_j) = (1.0 - loc_fracdecay)*atm(ia_pCH4_14C,dum_i,dum_j)

  END SUBROUTINE sub_calc_oxidize_CH4
  ! ****************************************************************************************************************************** !

  ! ****************************************************************************************************************************** !
  ! WETLANDS CH4 FLUX
  SUBROUTINE sub_calc_wetlands_CH4(dum_dtyr,dum_fatm)
    IMPLICIT NONE
    ! dummy arguments
    real,intent(in)::dum_dtyr
    REAL,DIMENSION(n_atm),intent(inout)::dum_fatm              ! flux to atmosphere (mol)
    ! local variables
    REAL::loc_flux_CH4,loc_flux_CH4_13C                        ! local CH4 flux
    real::loc_tot,loc_standard                                 ! local isotopic variables

    ! *** INITIALIZE LOCAL VARIABLES ***
    dum_fatm(:) = 0.0

    ! *** CALCULATE 'WETLANDS' CH4 FLUX TO ATMOSPHERE ***
    ! NOTE: multiply by 1/(imax x jmax) to divide up total emissions equally across all grid cells
    ! NOTE: loc_fatm in units of (mol), par_atm_wetlands_FCH4 in units of (mol yr-1)
    loc_flux_CH4 = dum_dtyr*(1.0/real(n_i*n_j))*par_atm_wetlands_FCH4

    ! *** ADD 'WETLAND' CH4 EMISSIONS SOURCE TO ATMOSPHERE ***
    dum_fatm(ia_pCH4) = dum_fatm(ia_pCH4) + loc_flux_CH4
    IF (atm_select(ia_pCH4_13C)) THEN
       loc_tot = loc_flux_CH4
       loc_standard = const_standards(atm_type(ia_pCH4_13C))
       loc_flux_CH4_13C = fun_calc_isotope_fraction(par_atm_wetlands_FCH4_d13C,loc_standard)*loc_tot
       dum_fatm(ia_pCH4_13C) = dum_fatm(ia_pCH4_13C) + loc_flux_CH4_13C
       IF (atm_select(ia_pCH4_14C)) THEN
          dum_fatm(ia_pCH4_14C) = dum_fatm(ia_pCH4_14C)
       end IF
    end IF

    ! *** BALANCE CO2 and O2 BUDGETS ***
    ! remove CO2 from atmosphere, assuming CO2 has at some point been removed to form wetland Corg and hence CH4
    ! add (2x) O2 to the atmopshere, again implicitly accounting for net O2 release upon Corg deposition in wetlands
    dum_fatm(ia_pCO2) = dum_fatm(ia_pCO2) - loc_flux_CH4
    IF (atm_select(ia_pCH4_13C) .AND. atm_select(ia_pCH4_13C)) THEN
       dum_fatm(ia_pCO2_13C) = dum_fatm(ia_pCO2_13C) - loc_flux_CH4_13C
       IF (atm_select(ia_pCO2_14C)) THEN
          dum_fatm(ia_pCO2_14C) = dum_fatm(ia_pCO2_14C)
       end IF
    end IF
    dum_fatm(ia_pO2) = dum_fatm(ia_pO2) + 2.0*loc_flux_CH4

  END SUBROUTINE sub_calc_wetlands_CH4
  ! ****************************************************************************************************************************** !

  ! ****************************************************************************************************************************** !
  ! PRODUCE 14C
  SUBROUTINE sub_calc_generate_14C(dum_dtyr,dum_fatm)
    IMPLICIT NONE
    ! dummy arguments
    real,intent(in)::dum_dtyr
    REAL,DIMENSION(n_atm),intent(inout)::dum_fatm              ! flux to atmosphere (mol)

    ! *** CALCULATE COSMOGENIC 14C FLUX ***
    dum_fatm(ia_pCO2_14C) = dum_fatm(ia_pCO2_14C) + dum_dtyr*(1.0/real(n_i*n_j))*par_atm_F14C

  END SUBROUTINE sub_calc_generate_14C
  ! ****************************************************************************************************************************** !

END MODULE atchem_box


! **********************************************************************************
! *         ROUTINES FOR COMPUTING THE Q MATRIX AND THE INCIDENT MATRIX FOR        *
! *                 AXISYMMETRIC AND NONAXISYMMETRIC PARTICLES                     *
! *    ------------------------------------------------------------------------    *
! *    Partial list of subroutines:                                                *
! *      matrix_Q,                   matrix_Q_sym,          matrix_Q_m,            *
! *      incident_matrix_m,          AzimMirSym,            ConvergenceMatrixElem  *
! **********************************************************************************
subroutine matrix_Q (FileGeom, TypeGeom, index1, index2, k, ind_ref, Nsurf, surf,   &
           rp, np, area, Nface, Mrank, Nrank, Nmax, NintAL, Nparam, Nintparam,      &
           paramG1, paramG2, weightsG, mirror, Nazimutsym, perfectcond, chiral, kb, &
           A, nap, map)
!------------------------------------------------------------------------------------
! The routine computes the Q matrix of a nonaxisymmetric particle.                  !
!------------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: Nface, Mrank, Nrank, Nmax, Nsurf, NintAL, Nparam, Nintparam(Nparam),&
                TypeGeom, index1, index2, Nazimutsym, nap, map
  real(O)    :: k, surf(Nsurf), paramG1(Nparam,NintAL*NintAL),                      &
                paramG2(Nparam,NintAL*NintAL), weightsG(Nparam,NintAL*NintAL),      &
                rp(3,NfacePD), np(3,NfacePD), area(NfacePD), kb
  complex(O) :: ind_ref, A(2*nap,2*map)
  logical    :: FileGeom, mirror, perfectcond, chiral
!
  integer    :: NmaxL, NmaxC, i, j, pint, iparam, Nintl
  real(O)    :: r, theta, phi, dA, param1, param2, pondere, nuv(3), sign, x, y, z
  complex(O) :: ki, zc, zl, zcl, zcr, fact, f
  complex(O),allocatable :: mv1(:,:), nv1(:,:), mv3(:,:), nv3(:,:)
!
  NmaxL = Nmax
  NmaxC = Nmax
  allocate (mv1(3,NmaxC), nv1(3,NmaxC), mv3(3,NmaxL), nv3(3,NmaxL))
  do i = 1, 2*NmaxL
    do j = 1, 2*NmaxC
      A(i,j) = zero
    end do
  end do
  ki   = k * ind_ref
  sign = 1._O
  if (index1 == 3 .and. index2 == 1) sign = - 1._O
  f = sign * im * k * k / Pi
  if (.not. FileGeom) then
    do iparam = 1, Nparam
      Nintl = Nintparam(iparam)
      do pint = 1, Nintl
        param1  = paramG1(iparam,pint)
        param2  = paramG2(iparam,pint)
        pondere = weightsG(iparam,pint)
        call elem_geom3D (TypeGeom, Nsurf, surf, param1, param2, iparam, r, theta,  &
             phi, dA, nuv, mirror, Nazimutsym)
        zc = ki * r
        zl = cmplx(k * r,0.0,O)
        if (chiral) then
          zcl = zc / (1._O - kb)
          zcr = zc / (1._O + kb)
        end if
        call mvnv (index1, index2, chiral, zl, zc, zcl, zcr, theta, phi, Mrank,     &
             Nrank, Nmax, NmaxC, NmaxL, mv3, nv3, mv1, nv1)
        fact = f * dA * pondere
        call matQ (NmaxC, NmaxL, chiral, perfectcond, ind_ref, fact, mv3, nv3,      &
             mv1, nv1, nuv, A, nap, map)
      end do
    end do
  else
    do pint = 1, Nface
      x = rp(1,pint)
      y = rp(2,pint)
      z = rp(3,pint)
      call T_cartesian_spherical (x, y, z, r, theta, phi)
      dA = area(pint)
      nuv(1) =   sin(theta) * cos(phi) * np(1,pint) +                               &
                 sin(theta) * sin(phi) * np(2,pint) + cos(theta) * np(3,pint)
      nuv(2) =   cos(theta) * cos(phi) * np(1,pint) +                               &
                 cos(theta) * sin(phi) * np(2,pint) - sin(theta) * np(3,pint)
      nuv(3) = - sin(phi) * np(1,pint) + cos(phi) * np(2,pint)
      zc = ki * r
      zl = cmplx(k * r,0.0,O)
      if (chiral) then
        zcl = zc / (1._O - kb)
        zcr = zc / (1._O + kb)
      end if
      call mvnv (index1, index2, chiral, zl, zc, zcl, zcr, theta, phi, Mrank,       &
           Nrank, Nmax, NmaxC, NmaxL, mv3, nv3, mv1, nv1)
      fact = f * dA
      call matQ (NmaxC, NmaxL, chiral, perfectcond, ind_ref, fact, mv3, nv3,        &
           mv1, nv1, nuv, A, nap, map)
    end do
  end if
  call AzimMirSym (Nazimutsym, mirror, Mrank, Nrank, NmaxC, NmaxL, A, nap, map)
  deallocate (mv1, nv1, mv3, nv3)
end subroutine matrix_Q
!***********************************************************************************
subroutine matrix_Q_sym (TypeGeom, index1, index2, k, ind_ref, Nsurf, surf, Mrank,  &
           Nrank, Nmax, Nint, Nparam, Nintparam, paramG, weightsG, mirror,          &
           perfectcond, A, nap, map)
!------------------------------------------------------------------------------------
! The routine computes the Q matrix of an axisymmetric particle, for the            !
! azimuthal modes m = 0, 1,..., Mrank. Only localized sources are used for          !
! calculation.                                                                      !
!------------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: Mrank, Nrank, Nmax, Nsurf, Nint, Nparam, Nintparam(Nparam),         &
                TypeGeom, index1, index2, nap, map
  real(O)    :: k, surf(Nsurf), paramG(Nparam,Nint), weightsG(Nparam,Nint)
  complex(O) :: ind_ref, A(2*nap,2*map)
  logical    :: mirror, perfectcond
!
  integer    :: i, j, pint, m, N0, N1, iparam, Nintl, ni, nj
  real(O)    :: r, theta, phi, dA, param, pondere, nuv(3), s
  complex(O) :: ki, zc, zl, mvl(3), nvl(3), mvc(3), nvc(3), v1, v2, fact, f,        &
                mixt_product
  complex(O),allocatable :: mv1(:,:), nv1(:,:), mv3(:,:), nv3(:,:)
!
  allocate (mv1(3,Nmax), nv1(3,Nmax), mv3(3,Nmax), nv3(3,Nmax))
  do i = 1, 2*Nmax
    do j = 1, 2*Nmax
      A(i,j) = zero
    end do
  end do
  ki = k * ind_ref
  f  = im * 2._O * k * k
  do iparam = 1, Nparam
    Nintl = Nintparam(iparam)
    do pint = 1, Nintl
      param   = paramG(iparam,pint)
      pondere = weightsG(iparam,pint)
      call elem_geomAXSYM (TypeGeom, Nsurf, surf, param, iparam, r, theta, phi,     &
           dA, nuv)
      zc = ki * r
      zl = cmplx(k * r,0.0,O)
      if (index1 == 3 .and. index2 == 1) then
        call MN_complete (3, zl, theta, phi, Mrank, Nrank, Nmax,.false.,.true.,     &
             mv3, nv3)
        call MN_complete (1, zc, theta, phi, Mrank, Nrank, Nmax,.true.,.true.,      &
             mv1, nv1)
      else if (index1 == 3 .and. index2 == 3) then
        call MN_complete (3, zl, theta, phi, Mrank, Nrank, Nmax,.false.,.true.,     &
             mv3, nv3)
        call MN_complete (3, zc, theta, phi, Mrank, Nrank, Nmax,.true.,.true.,      &
             mv1, nv1)
      else if (index1 == 1 .and. index2 == 1) then
        call MN_complete (1, zl, theta, phi, Mrank, Nrank, Nmax,.false.,.true.,     &
             mv3, nv3)
        call MN_complete (1, zc, theta, phi, Mrank, Nrank, Nmax,.true.,.true.,      &
             mv1, nv1)
      else if (index1 == 1 .and. index2 == 3) then
        call MN_complete (1, zl, theta, phi, Mrank, Nrank, Nmax,.false.,.true.,     &
             mv3, nv3)
        call MN_complete (3, zc, theta, phi, Mrank, Nrank, Nmax,.true.,.true.,      &
             mv1, nv1)
      end if
      fact = f * dA * pondere
      do m = 0, Mrank
        if (m == 0) then
          do i = 1, Nrank
            ni = i
            mvl(1) = mv3(1,i)
            mvl(2) = mv3(2,i)
            mvl(3) = mv3(3,i)
            nvl(1) = nv3(1,i)
            nvl(2) = nv3(2,i)
            nvl(3) = nv3(3,i)
            do j = 1, Nrank
              nj = j
              mvc(1) = mv1(1,j)
              mvc(2) = mv1(2,j)
              mvc(3) = mv1(3,j)
              nvc(1) = nv1(1,j)
              nvc(2) = nv1(2,j)
              nvc(3) = nv1(3,j)
              s = (-1._O)**(ni + nj)
              v1 = mixt_product (nuv, mvc, nvl)
              v2 = mixt_product (nuv, nvc, mvl)
              if (.not. perfectcond) then
                A(i,j) = A(i,j) + (v1 + ind_ref * v2) * fact
                if(mirror) A(i,j) = A(i,j) + s * (v1 + ind_ref * v2) * fact
              else
                A(i,j) = A(i,j) + v2 * fact
                if (mirror) A(i,j) = A(i,j) + s * v2 * fact
              end if
              v1 = mixt_product (nuv, nvc, mvl)
              v2 = mixt_product (nuv, mvc, nvl)
              if (.not. perfectcond) then
                A(i+Nmax,j+Nmax) = A(i+Nmax,j+Nmax) + (v1 + ind_ref * v2) * fact
                if (mirror) A(i+Nmax,j+Nmax) = A(i+Nmax,j+Nmax) +                   &
                                              s * (v1 + ind_ref * v2) * fact
              else
                A(i+Nmax,j+Nmax) = A(i+Nmax,j+Nmax) + v2*fact
                if (mirror) A(i+Nmax,j+Nmax) = A(i+Nmax,j+Nmax) + s * v2 * fact
              end if
            end do
          end do
        else
          N0 = Nrank + (m - 1) * (2 * Nrank - m + 2)
          do i = 1, Nrank - m + 1
            ni = m + i - 1
            mvl(1) = mv3(1,i+N0)
            mvl(2) = mv3(2,i+N0)
            mvl(3) = mv3(3,i+N0)
            nvl(1) = nv3(1,i+N0)
            nvl(2) = nv3(2,i+N0)
            nvl(3) = nv3(3,i+N0)
            do j = 1, Nrank - m + 1
              nj = m + j - 1
              mvc(1) = mv1(1,j+N0)
              mvc(2) = mv1(2,j+N0)
              mvc(3) = mv1(3,j+N0)
              nvc(1) = nv1(1,j+N0)
              nvc(2) = nv1(2,j+N0)
              nvc(3) = nv1(3,j+N0)
              s  = (-1._O)**(ni + nj)
              v1 = mixt_product (nuv, mvc, nvl)
              v2 = mixt_product (nuv, nvc, mvl)
              if (.not. perfectcond) then
                A(i+N0,j+N0) = A(i+N0,j+N0) + (v1 + ind_ref * v2) * fact
                if(mirror) A(i+N0,j+N0) = A(i+N0,j+N0) +                            &
                                         s * (v1 + ind_ref * v2) * fact
              else
                A(i+N0,j+N0) = A(i+N0,j+N0) + v2 * fact
                if(mirror) A(i+N0,j+N0) = A(i+N0,j+N0) + s * v2 * fact
              end if
              v1 = mixt_product (nuv, nvc, nvl)
              v2 = mixt_product (nuv, mvc, mvl)
              if (.not. perfectcond) then
                A(i+N0,j+N0+Nmax) = A(i+N0,j+N0+Nmax) + (v1 + ind_ref * v2) * fact
                if (mirror) A(i+N0,j+N0+Nmax) = A(i+N0,j+N0+Nmax) -                 &
                                               s * (v1 + ind_ref * v2) * fact
              else
                A(i+N0,j+N0+Nmax) = A(i+N0,j+N0+Nmax) + v2 * fact
                if (mirror) A(i+N0,j+N0+Nmax) = A(i+N0,j+N0+Nmax) - s * v2 * fact
              end if
              v1 = mixt_product (nuv, mvc, mvl)
              v2 = mixt_product (nuv, nvc, nvl)
              if (.not. perfectcond) then
                A(i+N0+Nmax,j+N0) = A(i+N0+Nmax,j+N0) + (v1 + ind_ref * v2) * fact
                if (mirror) A(i+N0+Nmax,j+N0) = A(i+N0+Nmax,j+N0) -                 &
                                               s * (v1 + ind_ref * v2) * fact
              else
                A(i+N0+Nmax,j+N0) = A(i+N0+Nmax,j+N0) + v2 * fact
                if (mirror) A(i+N0+Nmax,j+N0) = A(i+N0+Nmax,j+N0) - s * v2 * fact
              end if
              v1 = mixt_product (nuv, nvc, mvl)
              v2 = mixt_product (nuv, mvc, nvl)
              if (.not. perfectcond) then
                A(i+N0+Nmax,j+N0+Nmax) = A(i+N0+Nmax,j+N0+Nmax) +                   &
                                        (v1 + ind_ref * v2) * fact
                if (mirror) A(i+N0+Nmax,j+N0+Nmax) = A(i+N0+Nmax,j+N0+Nmax) +       &
                                                    s * (v1+ind_ref * v2) * fact
              else
                A(i+N0+Nmax,j+N0+Nmax) = A(i+N0+Nmax,j+N0+Nmax) + v2 * fact
                if (mirror) A(i+N0+Nmax,j+N0+Nmax) = A(i+N0+Nmax,j+N0+Nmax) +       &
                                                    s * v2 * fact
              end if
            end do
          end do
          N1 = N0 + Nrank - m + 1
          do i = 1, Nrank - m + 1
            do j = 1, Nrank - m + 1
              A(i+N1,j+N1) = A(i+N0,j+N0)
              A(i+N1,j+N1+Nmax) = - A(i+N0,j+N0+Nmax)
              A(i+N1+Nmax,j+N1) = - A(i+N0+Nmax,j+N0)
              A(i+N1+Nmax,j+N1+Nmax) = A(i+N0+Nmax,j+N0+Nmax)
            end do
          end do
        end if
      end do
    end do
  end do
  deallocate (mv1, nv1, mv3, nv3)
end subroutine matrix_Q_sym
!***********************************************************************************
subroutine matrix_Q_m (FileGeom, TypeGeom, index1, index2, k, ind_ref, Nsurf, surf, &
           rp, np, area, Nface, zRe, zIm, m, Nrank, Nmax, Nint, Nparam, Nintparam,  &
           paramG, weightsG, mirror, perfectcond, DS, chiral, kb, A, nap, map)
!------------------------------------------------------------------------------------
! The routine computes the Q matrix of an axisymmetric particle, and the            !
! azimuthal mode m                                                                  !
!------------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: m, Nrank, Nmax, Nsurf, Nface, Nint, Nparam, Nintparam(Nparam),      &
                TypeGeom, index1, index2, nap, map
  real(O)    :: k, kb, surf(Nsurf), paramG(Nparam,Nint), weightsG(Nparam,Nint),     &
                zRe(Nrank), zIm(Nrank), rp(2,NfacePD), np(2,NfacePD), area(NfacePD)
  complex(O) :: ind_ref, A(2*nap,2*map)
  logical    :: FileGeom, mirror, perfectcond, DS, chiral
!
  integer    :: NmaxL, NmaxC, i, j, pint, iparam, Nintl
  real(O)    :: r, theta, phi, dA, param, pondere, nuv(3), sign, x, z, za, thetaA
  complex(O) :: kc, ki, kil, kir, zc, zl, zcl, zcr, fact, f
  complex(O),allocatable :: mv1(:,:), nv1(:,:), mv3(:,:), nv3(:,:)
!
  NmaxL = Nmax
  NmaxC = Nmax
  if (DS) then
    NmaxC = Nrank
    if (index1 == 3) then
      NmaxL = Nrank
    else if (index1 == 1) then
      NmaxL = Nmax
    end if
  end if
  allocate (mv1(3,NmaxC), nv1(3,NmaxC), mv3(3,NmaxL), nv3(3,NmaxL))
  kc = cmplx(k,0.0,O)
  do i = 1, 2*NmaxL
    do j = 1, 2*NmaxC
      A(i,j) = zero
    end do
  end do
  ki = k * ind_ref
  if (chiral) then
    kil = ki / (1._O - kb)
    kir = ki / (1._O + kb)
  end if
  sign = 1._O
  if (index1 == 3 .and. index2 == 1) sign = - 1._O
  f = sign * im * 2._O * k * k
  if (.not. FileGeom) then
    do iparam = 1, Nparam
      Nintl = Nintparam(iparam)
      do pint = 1, Nintl
        param   = paramG(iparam,pint)
        pondere = weightsG(iparam,pint)
        call elem_geomAXSYM (TypeGeom, Nsurf, surf, param, iparam, r, theta, phi,   &
             dA, nuv)
        zc = ki * r
        zl = cmplx(k * r,0.0,O)
        if (chiral) then
          zcl = zc / (1._O - kb)
          zcr = zc / (1._O + kb)
        end if
        call mvnv_m (index1, index2, chiral, DS, zl, zc, zcl, zcr, kc, ki, kil, kir,&
             r, theta, m, Nrank, Nmax, NmaxC, NmaxL, zRe, zIm, mv3, nv3, mv1, nv1)
        fact = f * dA * pondere
        call matQ_m (m, NmaxC, NmaxL, chiral, perfectcond, mirror, ind_ref, fact,   &
             mv3, nv3, mv1, nv1, nuv, A, nap, map)
      end do
    end do
  else
    do pint = 1, Nface
      x  = rp(1,pint)
      z  = rp(2,pint)
      r  = sqrt(x * x + z * z)
      za = abs(z)
      if (za < MachEps) then
        theta = Pi / 2._O
      else
        thetaA = atan(x / za)   ! x > 0
        if (z >= MachEps) then
          theta = thetaA
        else
          theta = Pi - thetaA
        end if
      end if
      dA = area(pint)
      nuv(1) =   np(2,pint) * cos(theta) + np(1,pint) * sin(theta)
      nuv(2) = - np(2,pint) * sin(theta) + np(1,pint) * cos(theta)
      nuv(3) = 0._O
      zc = ki * r
      zl = cmplx(k * r,0.0,O)
      if (chiral) then
        zcl = zc / (1._O - kb)
        zcr = zc / (1._O + kb)
      end if
      call mvnv_m (index1, index2, chiral, DS, zl, zc, zcl, zcr, kc, ki, kil, kir,  &
           r, theta, m, Nrank, Nmax, NmaxC, NmaxL, zRe, zIm, mv3, nv3, mv1, nv1)
      fact = f * dA
      call matQ_m (m, NmaxC, NmaxL, chiral, perfectcond, mirror, ind_ref, fact,     &
           mv3, nv3, mv1, nv1, nuv, A, nap, map)
    end do
  end if
  deallocate (mv1, nv1, mv3, nv3)
end subroutine matrix_Q_m
!***********************************************************************************
subroutine incident_matrix_m (FileGeom, TypeGeom, k, Nsurf, surf, rp, np, area,     &
           Nface, zRe, zIm, m, Nrank, Nmax, Nint, Nparam, Nintparam, paramG,        &
           weightsG, A, nap, map)
!-----------------------------------------------------------------------------------
! The routine computes the incident matrix of an axisymmetric particle             !
! using distributed sources.                                                       !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: TypeGeom, m, Nrank, Nmax, Nint, Nsurf, Nparam, Nintparam(Nparam),   &
                nap, map, Nface
  real(O)    :: k, surf(Nsurf), zRe(Nrank), zIm(Nrank), paramG(Nparam,Nint),        &
                weightsG(Nparam,Nint), rp(2,NfacePD), np(2,NfacePD), area(NfacePD)
  complex(O) :: A(2*nap,2*map)
  logical    :: FileGeom
!
  integer    :: i, j, pint, iparam, Nintl
  real(O)    :: r, theta, phi, dA, param, pondere, nuv(3), x, z, za, thetaA
  complex(O) :: kc, zl, fact, f
  complex(O),allocatable :: mv1(:,:), nv1(:,:), mv3(:,:), nv3(:,:)
!
  allocate (mv1(3,Nmax), nv1(3,Nmax), mv3(3,Nrank), nv3(3,Nrank))
  kc = cmplx(k,0.0,O)
  do i = 1, 2*Nrank
    do j = 1, 2*Nmax
      A(i,j) = zero
    end do
  end do
  f = - im * 2._O * k * k
  if (.not. FileGeom) then
    do iparam = 1, Nparam
      Nintl = Nintparam(iparam)
      do pint = 1, Nintl
        param   = paramG(iparam,pint)
        pondere = weightsG(iparam,pint)
        call elem_geomAXSYM (TypeGeom, Nsurf, surf, param, iparam, r, theta, phi,   &
             dA, nuv)
        zl = cmplx(k * r,0.0,O)
        call mvnvinc_m (zl, kc, r, theta, m, Nrank, Nmax, zRe, zIm, mv3, nv3,       &
             mv1, nv1)
        fact = f * dA * pondere
        call matQinc_m (m, Nmax, Nrank, fact, mv3, nv3, mv1, nv1, nuv, A, nap, map)
      end do
    end do
  else
    do pint = 1, Nface
      x  = rp(1,pint)
      z  = rp(2,pint)
      r  = sqrt(x * x + z * z)
      za = abs(z)
      if (za < MachEps) then
        theta = Pi / 2._O
      else
        thetaA = atan(x / za)   ! x > 0
        if (z >= MachEps) then
          theta = thetaA
        else
          theta = Pi - thetaA
        end if
      end if
      dA = area(pint)
      nuv(1) =   np(2,pint) * cos(theta) + np(1,pint) * sin(theta)
      nuv(2) = - np(2,pint) * sin(theta) + np(1,pint) * cos(theta)
      nuv(3) = 0._O
      zl = cmplx(k * r,0.0,O)
      call mvnvinc_m (zl, kc, r, theta, m, Nrank, Nmax, zRe, zIm, mv3, nv3,         &
           mv1, nv1)
      fact = f * dA
      call matQinc_m (m, Nmax, Nrank, fact, mv3, nv3, mv1, nv1, nuv, A, nap, map)
    end do
  end if
  deallocate (mv1, nv1, mv3, nv3)
end subroutine incident_matrix_m
!***********************************************************************************
subroutine AzimMirSym (Nazimutsym, mirror, Mrank, Nrank, NmaxC, NmaxL, A, nap, map)
!-----------------------------------------------------------------------------------
! The routine completes the calculation of the Q matrix of a nonaxisymmetric       !
! particle taking into account the mirror and azimuthal symmetry.                  !
! Note: The real dimensions of A are (2*NmaxL,2*NmaxC). The rows are characterized !
! by the azimuthal indices                                                         !
!                             m = 0,-1,+1,-2,+2,...,                               !
! while the columns are characterized by zhe azimuthal indices                     !
!                             m'= 0,+1,-1,+2,-2,...                                !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: Nazimutsym, Mrank, Nrank, NmaxC, NmaxL, nap, map
  complex(O) :: A(2*nap,2*map)
  logical    :: mirror
!
  integer    :: m, ml, n, m1, m1l, n1, i, j, p, Nc, Nl, l, l1
  real(O)    :: dalfa, arg, sp, sm
  complex(O) :: fact
!
  if (Nazimutsym >= 2 .or. mirror) then
    if (Nazimutsym >= 2) dalfa = 2._O * Pi / Nazimutsym
    do m = 0, Mrank
      if (m == 0) then
        ml = m
        do i = 1, Nrank
          n = i
          do m1 = 0, Mrank
            if (m1 == 0) then
              m1l = m1
              if (mirror) then
                do j = 1, Nrank
                  n1 = j
                  sp = 1._O + (-1._O)**(n + n1 + m + m1)
                  sm = 2._O - sp
                  A(i,j) = sp * A(i,j)
                  A(i,j+NmaxC) = sm * A(i,j+NmaxC)
                  A(i+NmaxL,j) = sm * A(i+NmaxL,j)
                  A(i+NmaxL,j+NmaxC) = sp * A(i+NmaxL,j+NmaxC)
                end do
              end if
              if (Nazimutsym >= 2) then
                fact = one
                do p = 2, Nazimutsym
                  arg  = real((ml + m1l) * (p - 1),O) * dalfa
                  fact = fact + exp(im * arg)
                end do
                do j = 1, Nrank
                  A(i,j) = fact * A(i,j)
                  A(i,j+NmaxC) = fact * A(i,j+NmaxC)
                  A(i+NmaxL,j) = fact * A(i+NmaxL,j)
                  A(i+NmaxL,j+NmaxC) = fact * A(i+NmaxL,j+NmaxC)
                end do
              end if
            else
              m1l = m1
              Nc  = Nrank + (m1 - 1) * (2*Nrank - m1 + 2)
              do l1 = 1, 2
                if (mirror) then
                  do j = 1, Nrank - m1 + 1
                    n1 = m1 + j - 1
                    sp = 1._O + (-1._O)**(n + n1 + m + m1)
                    sm = 2._O - sp
                    A(i,j+Nc) = sp * A(i,j+Nc)
                    A(i,j+Nc+NmaxC) = sm * A(i,j+Nc+NmaxC)
                    A(i+NmaxL,j+Nc) = sm * A(i+NmaxL,j+Nc)
                    A(i+NmaxL,j+Nc+NmaxC) = sp * A(i+NmaxL,j+Nc+NmaxC)
                  end do
                end if
                if (Nazimutsym >= 2) then
                  fact = one
                  do p = 2, Nazimutsym
                    arg  = real((ml + m1l) * (p - 1),O) * dalfa
                    fact = fact + exp(im * arg)
                  end do
                  do j = 1, Nrank - m1 + 1
                    A(i,j+Nc) = fact * A(i,j+Nc)
                    A(i,j+Nc+NmaxC) = fact * A(i,j+Nc+NmaxC)
                    A(i+NmaxL,j+Nc) = fact * A(i+NmaxL,j+Nc)
                    A(i+NmaxL,j+Nc+NmaxC) = fact * A(i+NmaxL,j+Nc+NmaxC)
                  end do
                end if
                m1l = - m1l
                Nc  =   Nc + Nrank - m1 + 1
              end do
            end if
          end do
        end do
      else
        ml = - m
        Nl =   Nrank + (m - 1) * (2 * Nrank - m + 2)
        do l = 1, 2
          do i = 1, Nrank - m + 1
            n = m + i - 1
            do m1 = 0, Mrank
              if (m1 == 0) then
                m1l = m1
                if (mirror) then
                  do j = 1, Nrank
                    n1 = j
                    sp = 1._O + (-1._O)**(n + n1 + m + m1)
                    sm = 2._O - sp
                    A(i+Nl,j) = sp * A(i+Nl,j)
                    A(i+Nl,j+NmaxC) = sm * A(i+Nl,j+NmaxC)
                    A(i+Nl+NmaxL,j) = sm * A(i+Nl+NmaxL,j)
                    A(i+Nl+NmaxL,j+NmaxC) = sp * A(i+Nl+NmaxL,j+NmaxC)
                  end do
                end if
                if (Nazimutsym >= 2) then
                  fact = one
                  do p = 2, Nazimutsym
                    arg  = real((ml + m1l) * (p - 1),O) * dalfa
                    fact = fact + exp(im * arg)
                  end do
                  do j = 1, Nrank
                    A(i+Nl,j) = fact * A(i+Nl,j)
                    A(i+Nl,j+NmaxC) = fact * A(i+Nl,j+NmaxC)
                    A(i+Nl+NmaxL,j) = fact * A(i+Nl+NmaxL,j)
                    A(i+Nl+NmaxL,j+NmaxC) = fact * A(i+Nl+NmaxL,j+NmaxC)
                  end do
                end if
              else
                m1l = m1
                Nc  = Nrank + (m1 - 1) * (2 * Nrank - m1 + 2)
                do l1 = 1, 2
                  if (mirror) then
                    do j = 1, Nrank - m1 + 1
                      n1 = m1 + j - 1
                      sp = 1._O + (-1._O)**(n + n1 + m + m1)
                      sm = 2._O - sp
                      A(i+Nl,j+Nc) = sp * A(i+Nl,j+Nc)
                      A(i+Nl,j+Nc+NmaxC) = sm * A(i+Nl,j+Nc+NmaxC)
                      A(i+Nl+NmaxL,j+Nc) = sm * A(i+Nl+NmaxL,j+Nc)
                      A(i+Nl+NmaxL,j+Nc+NmaxC) = sp * A(i+Nl+NmaxL,j+Nc+NmaxC)
                    end do
                  end if
                  if (Nazimutsym >= 2) then
                    fact = one
                    do p = 2, Nazimutsym
                      arg  = real((ml + m1l) * (p - 1),O) * dalfa
                      fact = fact + exp(im * arg)
                    end do
                    do j = 1, Nrank - m1 + 1
                      A(i+Nl,j+Nc) = fact * A(i+Nl,j+Nc)
                      A(i+Nl,j+Nc+NmaxC) = fact * A(i+Nl,j+Nc+NmaxC)
                      A(i+Nl+NmaxL,j+Nc) = fact * A(i+Nl+NmaxL,j+Nc)
                      A(i+Nl+NmaxL,j+Nc+NmaxC) = fact * A(i+Nl+NmaxL,j+Nc+NmaxC)
                    end do
                  end if
                  m1l = - m1l
                  Nc  =  Nc + Nrank - m1 + 1
                end do
              end if
            end do
          end do
          ml = - ml
          Nl =   Nl + Nrank - m + 1
        end do
      end if
    end do
  end if
end subroutine AzimMirSym
!***********************************************************************************
subroutine ConvergenceMatrixElem ( index1, index2, TypeGeom, Nsurf, Nparam, ml, mc, &
           Nrank, NintMax, Nint1, Nint2, Nazimutsym, k, surf, kb, ind_ref, mirror,  &
           perfectcond, chiral )
  use parameters
  use derived_parameters
  implicit none
  integer    :: index1, index2, TypeGeom, Nsurf, Nparam, ml, mc, Nrank, NintMax,    &
                Nint1, Nint2, Nazimutsym
  real(O)    :: k, surf(Nsurf), kb
  complex(O) :: ind_ref
  logical    :: mirror, perfectcond, chiral
!
  integer    :: NmaxL, NmaxC, ml_minus, i, j, Nint1l, Nint2l, NintAL, iparam,       &
                Nintl, pint, iint, imn, jmn
  real(O)    :: r, theta, phi, dA, param1, param2, pondere, nuv(3), sign, MaxA(2),  &
                MinA(2)
  complex(O) :: ki, zc, zl, zcl, zcr, fact, f, mvl(3), nvl(3), mvc(3), nvc(3), v1,  &
                v2, mixt_product, A11(2,2), A12(2,2), A21(2,2), A22(2,2), expfctL,  &
                expfctC
  integer,allocatable    :: Nintparam(:)
  real(O),allocatable    :: paramG1(:,:), paramG2(:,:), weightsG(:,:)
  complex(O),allocatable :: mvl1(:,:), nvl1(:,:), mvr1(:,:), nvr1(:,:)
  complex(O),allocatable :: mv1(:,:), nv1(:,:), mv3(:,:), nv3(:,:)
!
  NmaxL = Nrank - ml + 1
  NmaxC = Nrank - mc + 1
  ml_minus = - ml
  allocate (mv1(3,NmaxC), nv1(3,NmaxC), mv3(3,NmaxL), nv3(3,NmaxL))
  if (chiral) allocate (mvl1(3,NmaxC), nvl1(3,NmaxC), mvr1(3,NmaxC), nvr1(3,NmaxC))
  ki   = k * ind_ref
  sign = 1._O
  if (index1 == 3 .and. index2 == 1) sign = - 1._O
  f = sign * im * k * k / Pi
  if (ml == 1) then
    print "(2x,'Integral Test over Matrix Elements of Blocks (1,Mrank):')"
  else
    print "(2x,'Integral Test over Matrix Elements of Blocks (Mrank,Mrank):')"
  end if
  print "(2x,'Nint1   Nint2          max-min (A11,A22)             max-min (A12,A21) ')"
  do iint = 1, NintMax
    Nint1l = Nint1 + iint - 1
    Nint2l = Nint2 + iint - 1
    NintAL = max(Nint1l,Nint2l)
    allocate (paramG1(Nparam,NintAL*NintAL), paramG2(Nparam,NintAL*NintAL),         &
              weightsG(Nparam,NintAL*NintAL))
    allocate (Nintparam(Nparam))
    call interpolation_list3D (TypeGeom, Nsurf, surf, Nint1l, Nint2l, NintAL,       &
         Nparam, Nintparam, paramG1, paramG2, weightsG, mirror, Nazimutsym)
    do i = 1, 2
      do j = 1, 2
        A11(i,j) = zero
        A12(i,j) = zero
        A21(i,j) = zero
        A22(i,j) = zero
      end do
    end do
    do iparam = 1, Nparam
      Nintl = Nintparam(iparam)
      do pint = 1, Nintl
        param1  = paramG1(iparam,pint)
        param2  = paramG2(iparam,pint)
        pondere = weightsG(iparam,pint)
        call elem_geom3D (TypeGeom, Nsurf, surf, param1, param2, iparam, r, theta,  &
             phi, dA, nuv, mirror, Nazimutsym)
        zc = ki * r
        zl = cmplx(k * r,0.0,O)
        if (chiral) then
          zcl = zc / (1._O - kb)
          zcr = zc / (1._O + kb)
        end if
        if (index1 == 3 .and. index2 == 1) then
          call MN (3, zl, theta, ml_minus, Nrank, NmaxL, mv3, nv3)
          if (.not. chiral) then
            call MN (1, zc, theta, mc, Nrank, NmaxC, mv1, nv1)
          else
            call MN (1, zcl, theta, mc, Nrank, NmaxC, mvl1, nvl1)
            call MN (1, zcr, theta, mc, Nrank, NmaxC, mvr1, nvr1)
            call MN_left_right (NmaxC, mvl1, nvl1, mvr1, nvr1, mv1, nv1)
          end if
        else if (index1 == 1 .and. index2 == 1) then
          call MN (1, zl, theta, ml_minus, Nrank, NmaxL, mv3, nv3)
          if (.not. chiral) then
            call MN (1, zc, theta, mc, Nrank, NmaxC, mv1, nv1)
          else
            call MN (1, zcl, theta, mc, Nrank, NmaxC, mvl1, nvl1)
            call MN (1, zcr, theta, mc, Nrank, NmaxC, mvr1, nvr1)
            call MN_left_right (NmaxC, mvl1, nvl1, mvr1, nvr1, mv1, nv1)
          end if
        end if
        fact    = f * dA * pondere
        expfctL =  exp(im * ml_minus * phi)
        expfctC =  exp(im * mc * phi)
        do i = 1, 2
          if (i == 1) then
            imn = 1
          else
            imn = NmaxL
          end if
          mvl(1) = mv3(1,imn) * expfctL
          mvl(2) = mv3(2,imn) * expfctL
          mvl(3) = mv3(3,imn) * expfctL
          nvl(1) = nv3(1,imn) * expfctL
          nvl(2) = nv3(2,imn) * expfctL
          nvl(3) = nv3(3,imn) * expfctL
          do j = 1, 2
            if (j == 1) then
              jmn = 1
            else
              jmn = NmaxC
            end if
            mvc(1) = mv1(1,jmn) * expfctC
            mvc(2) = mv1(2,jmn) * expfctC
            mvc(3) = mv1(3,jmn) * expfctC
            nvc(1) = nv1(1,jmn) * expfctC
            nvc(2) = nv1(2,jmn) * expfctC
            nvc(3) = nv1(3,jmn) * expfctC
            if (.not. chiral) then
              v1 = mixt_product (nuv, mvc, nvl)
              v2 = mixt_product (nuv, nvc, mvl)
              if (.not. perfectcond) then
                A11(i,j) = A11(i,j) + (v1 + ind_ref * v2) * fact
              else
                A11(i,j) = A11(i,j) + v2 * fact
              end if
            else
              v1 = mixt_product (nuv, mvc, nvl)
              v2 = mixt_product (nuv, mvc, mvl)
              A11(i,j) = A11(i,j) + (v1 + ind_ref * v2) * fact
            end if
            if (.not. chiral) then
              v1 = mixt_product (nuv, nvc, nvl)
              v2 = mixt_product (nuv, mvc, mvl)
              if (.not. perfectcond) then
                A12(i,j) = A12(i,j) + (v1 + ind_ref * v2) * fact
              else
                A12(i,j) = A12(i,j) + v2 * fact
              end if
              v1 = mixt_product (nuv, mvc, mvl)
              v2 = mixt_product (nuv, nvc, nvl)
              if (.not. perfectcond) then
                A21(i,j) = A21(i,j) + (v1 + ind_ref * v2) * fact
              else
                A21(i,j) = A21(i,j) + v2 * fact
              end if
            else
              v1 = mixt_product (nuv, nvc, nvl)
              v2 = mixt_product (nuv, nvc, mvl)
              A12(i,j) = A12(i,j) + (v1 - ind_ref * v2) * fact
              v1 = mixt_product (nuv, mvc, mvl)
              v2 = mixt_product (nuv, mvc, nvl)
              A21(i,j) = A21(i,j) + (v1 + ind_ref * v2) * fact
            end if
            if (.not. chiral) then
              v1 = mixt_product (nuv, nvc, mvl)
              v2 = mixt_product (nuv, mvc, nvl)
              if (.not. perfectcond) then
                A22(i,j) = A22(i,j) + (v1 + ind_ref * v2) * fact
              else
                A22(i,j) = A22(i,j) + v2 * fact
              end if
            else
              v1 = mixt_product (nuv, nvc, mvl)
              v2 = mixt_product (nuv, nvc, nvl)
              A22(i,j) = A22(i,j) + (v1 - ind_ref * v2) * fact
            end if
          end do
        end do
      end do
    end do
    MaxA(1) = max(abs(A11(1,1)), abs(A11(1,2)), abs(A11(2,1)), abs(A11(2,2)),       &
                  abs(A22(1,1)), abs(A22(1,2)), abs(A22(2,1)), abs(A22(2,2)))
    MinA(1) = min(abs(A11(1,1)), abs(A11(1,2)), abs(A11(2,1)), abs(A11(2,2)),       &
                  abs(A22(1,1)), abs(A22(1,2)), abs(A22(2,1)), abs(A22(2,2)))

    MaxA(2) = max(abs(A12(1,1)), abs(A12(1,2)), abs(A12(2,1)), abs(A12(2,2)),       &
                  abs(A21(1,1)), abs(A21(1,2)), abs(A21(2,1)), abs(A21(2,2)))
    MinA(2) = min(abs(A12(1,1)), abs(A12(1,2)), abs(A12(2,1)), abs(A12(2,2)),       &
                  abs(A21(1,1)), abs(A21(1,2)), abs(A21(2,1)), abs(A21(2,2)))
    print "(3x,i3,5x,i3,4x,1pe14.6,1x,1pe14.6,1x,1pe14.6,1x,1pe14.6)", Nint1l,      &
            Nint2l, MaxA(1), MinA(1), MaxA(2), MinA(2)
    deallocate (paramG1, paramG2, weightsG, Nintparam)
  end do
  deallocate (mv1, nv1, mv3, nv3)
  if (chiral) deallocate (mvl1, nvl1, mvr1, nvr1)
end subroutine ConvergenceMatrixElem


SUBROUTINE neo_init_s(psi,dpsi)
! Initialization for Specific Magnetic Surface
! **********************************************************************
! Modules
! **********************************************************************
  USE neo_precision
  USE neo_input
  USE neo_work
  USE neo_exchange
  USE neo_units
  USE neo_parameters
  USE neo_control
  USE neo_spline
! **********************************************************************
! Local Definitions
! **********************************************************************
  IMPLICIT NONE

  REAL(kind=dp),                INTENT(out)     :: psi, dpsi
  INTEGER,       DIMENSION(2)                   :: b_minpos, b_maxpos

  REAL(kind=dp), PARAMETER                      :: eps_newt = 1.0e-10_dp
  INTEGER                                       :: iter, error
  INTEGER,       PARAMETER                      :: iterma_newt = 100
  REAL(kind=dp)                                 :: gval_bmin
  REAL(kind=dp)                                 :: kval_bmin,pval_bmin
  REAL(kind=dp)                                 :: gval_bmax
  REAL(kind=dp)                                 :: kval_bmax,pval_bmax
  REAL(kind=dp)                                 :: qval_bmin,qval_bmax

  REAL(kind=dp)  :: tht, pht, f, g, dfdx, dfdy, dgdx, dgdy
  REAL(kind=dp)  :: thi, phi
  REAL(kind=dp)  :: iot,bval,gval,kval,pval
  INTEGER        :: i
! **********************************************************************
! Calculate Fourier sums and derived quantities
! **********************************************************************
!  IF (write_progress .NE. 0) WRITE (w_us,*) 'before neo_fourier'
  CALL neo_fourier
!  IF (write_progress .NE. 0) WRITE (w_us,*) 'after  neo_fourier'
! **********************************************************************
! Calculation of dpsi
! **********************************************************************
  psi = es(psi_ind)
  IF (psi_ind .EQ. 1) THEN
     dpsi = 0
  ELSE
     dpsi = psi - es(psi_ind-1)
  ENDIF
! **********************************************************************
! Initilaze spline arrays
! **********************************************************************
! IF (write_progress .NE. 0) WRITE (w_us,*) 'before neo_spline2d'
  CALL neo_spline2d
! IF (write_progress .NE. 0) WRITE (w_us,*) 'after  neo_spline2d'
! **********************************************************************
! Calculate absolute minimum and maximum of b and its location (theta, phi)
! **********************************************************************
  b_minpos   = MINLOC(b)
  b_min      = b(b_minpos(1),b_minpos(2))
  theta_bmin = theta_arr(b_minpos(1))
  phi_bmin   = phi_arr(b_minpos(2))

  b_maxpos   = MAXLOC(b)
  b_max      = b(b_maxpos(1),b_maxpos(2))
  theta_bmax = theta_arr(b_maxpos(1))
  phi_bmax   = phi_arr(b_maxpos(2))

! IF (write_progress .NE. 0) WRITE (w_us,*) 'before neo_zeros2d (min)'
  CALL neo_zeros2d(theta_bmin, phi_bmin, eps_newt, iterma_newt, iter, error)
  CALL neo_eval(theta_bmin,phi_bmin,b_min,gval_bmin,kval_bmin,&
                pval_bmin,qval_bmin)
! IF (write_progress .NE. 0) WRITE (w_us,*) 'after  neo_zeros2d'

! IF (write_progress .NE. 0) WRITE (w_us,*) 'before neo_zeros2d (max)'
  CALL neo_zeros2d(theta_bmax, phi_bmax, eps_newt, iterma_newt, iter, error)
  CALL neo_eval(theta_bmax,phi_bmax,b_max,gval_bmax,kval_bmax,&
                pval_bmax,qval_bmax)
! IF (write_progress .NE. 0) WRITE (w_us,*) 'after  neo_zeros2d'
! **********************************************************************
! ATTENTION
! Set bmref to the absolute maximum of b on flux surface
! This is absolutely necessary for internal routines
! Rescaling is done at the end of the main program neo.f90
! **********************************************************************
  bmref = b_max
  RETURN
END SUBROUTINE neo_init_s


FUNCTION Pressure(k1_in)

    USE Atmosphere
    USE AirfoilParams
    USE BLParams
    use ISO_FORTRAN_ENV
    USE TNOConstants
    USE Wavenumber

    implicit none

    ! Variables
    REAL (kind=4):: a,b,answer
    REAL (kind=4):: abserr,resabs,resasc

    REAL (kind=4):: k1_in,Pressure

    REAL (kind=4), EXTERNAL :: int1

    a = 0. !1e-4*d99(1)
    IF (ISSUCTION)THEN
        b = d99(1)
    ELSE
        b = d99(2)
    ENDIF

    k1 = k1_in
    k3 = 0.
    k= sqrt(k1**2+k3**2)

    CALL qk61(int1,a,b,answer,abserr,resabs,resasc)

    Pressure = 4.*rho**2*k1**2./(k1**2.+k3**2.)*answer

RETURN

END FUNCTION Pressure


      DOUBLE PRECISION FUNCTION bup(a,b,x,y,n,eps)
C-----------------------------------------------------------------------
C     EVALUATION OF IX(A,B) - IX(A+N,B) WHERE N IS A POSITIVE INTEGER.
C     EPS IS THE TOLERANCE USED.
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a,b,eps,x,y
      INTEGER n
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION ap1,apb,d,l,r,t,w
      INTEGER i,k,kp1,mu,nm1
C     ..
C     .. External Functions ..
      DOUBLE PRECISION brcmp1,exparg
      EXTERNAL brcmp1,exparg
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,exp
C     ..
C     .. Executable Statements ..
C
C          OBTAIN THE SCALING FACTOR EXP(-MU) AND
C             EXP(MU)*(X**A*Y**B/BETA(A,B))/A
C
      apb = a + b
      ap1 = a + 1.0D0
      mu = 0
      d = 1.0D0
      IF (n.EQ.1 .OR. a.LT.1.0D0) GO TO 10
      IF (apb.LT.1.1D0*ap1) GO TO 10
      mu = abs(exparg(1))
      k = exparg(0)
      IF (k.LT.mu) mu = k
      t = mu
      d = exp(-t)
C
   10 bup = brcmp1(mu,a,b,x,y)/a
      IF (n.EQ.1 .OR. bup.EQ.0.0D0) RETURN
      nm1 = n - 1
      w = d
C
C          LET K BE THE INDEX OF THE MAXIMUM TERM
C
      k = 0
      IF (b.LE.1.0D0) GO TO 50
      IF (y.GT.1.D-4) GO TO 20
      k = nm1
      GO TO 30

   20 r = (b-1.0D0)*x/y - a
      IF (r.LT.1.0D0) GO TO 50
      k = nm1
      t = nm1
      IF (r.LT.t) k = r
C
C          ADD THE INCREASING TERMS OF THE SERIES
C
   30 DO 40 i = 1,k
          l = i - 1
          d = ((apb+l)/ (ap1+l))*x*d
          w = w + d
   40 CONTINUE
      IF (k.EQ.nm1) GO TO 70
C
C          ADD THE REMAINING TERMS OF THE SERIES
C
   50 kp1 = k + 1
      DO 60 i = kp1,nm1
          l = i - 1
          d = ((apb+l)/ (ap1+l))*x*d
          w = w + d
          IF (d.LE.eps*w) GO TO 70
   60 CONTINUE
C
C               TERMINATE THE PROCEDURE
C
   70 bup = bup*w
      RETURN

      END