#INCLUDE 'MR_H_ALIGN_PADDING.H'
!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_CALC_EQD_SRC_XYZ

    USE MR_KINDS

    USE MR_DEF_CURVED_GEOS
    USE MR_DEF_CONSTS_N_REF_PARS
    USE MR_DEF_FIELD_VARS
    USE MR_DEF_ACTIVITY
    USE MR_DEF_TIMING

    USE MR_MOC_K_EPS

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_CALC_EQD_SRC_XYZ

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

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_CALC_EQD_SRC_XYZ( NI , NJ , K , EQKD_PRO_XY_K , EQKD_PRO_Z_K , EQD_SRC_XYZ )

    USE MR_MOD_OPERATOR_SS

    IMPLICIT NONE

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ

    INTEGER(KKID_KIND) , INTENT(IN ) :: K

    REAL   (FDRD_KIND) , INTENT(IN ) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ) :: EQKD_PRO_XY_K , EQKD_PRO_Z_K
    REAL   (FDRD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ) :: EQD_SRC_XYZ

    EQD_SRC_XYZ = + DT * RBT *   &
    ( MW .MRSSSCL.   &
      ( ( ( ( REAL( ( CD1 * ( EQKD_PRO_XY_K + EQKD_PRO_Z_K ) - CD2 * DI(:,:, K ) ) , FDRD_KIND ) )   &
              .MRSSMTP. DI(:,:, K )   &
          ) .MRSSDIV. KI(:,:, K )   &
        )   &
      )   &
    )

  END SUBROUTINE MR_CALC_EQD_SRC_XYZ

  END MODULE MR_MOD_CALC_EQD_SRC_XYZ


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2018 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine restrictor(node1,node2,nodem,nelem,lakon,kon,ipkon,
     &     nactdog,identity,ielprop,prop,iflag,v,xflow,f,
     &     nodef,idirf,df,cp,r,physcon,dvi,numf,set,
     &     shcon,nshcon,rhcon,nrhcon,ntmat_,mi,ttime,time,
     &     iaxial,co,vold,iplausi)
!
!     pressure loss element with partial total head loss
!
!     author: Yannick Muller
!
      implicit none
!
      logical identity,crit,isothermal
      character*8 lakon(*)
      character*81 set(*)
!
      integer nelem,nactdog(0:3,*),node1,node2,nodem,numf,
     &     ielprop(*),nodef(*),idirf(*),index,iflag,iaxial,
     &     inv,ipkon(*),kon(*),kgas,icase,k_oil,nshcon(*),
     &     nrhcon(*),ntmat_,mi(*),iplausi
!
      real*8 prop(*),v(0:mi(2),*),xflow,f,df(*),kappa,R,d,
     &     Tt1,Tt2,pt1,pt2,cp,physcon(*),km1,dvi,co(3,*),
     &     kp1,kdkm1,reynolds,kdkp1,ttime,time,
     &     pt2pt1,pt1pt2,pt1pt2_crit,qred_crit,qred1,qred2,zeta,
     &     A1,A2,root, expon1,expon2,expon3,fact1,fact2,sqrt,pi,
     &     pt2_lim,M2,M1,xflow_oil,T1,T2,phi,vold(0:mi(2),*),
     &     shcon(0:3,ntmat_,*),rhcon(0:1,ntmat_,*),zeta_phi,Aeff,
     &     C2,tdkp1
!
      intent(in) node1,node2,nodem,nelem,lakon,kon,ipkon,
     &     nactdog,ielprop,iflag,v,cp,r,physcon,dvi,set,
     &     shcon,nshcon,rhcon,nrhcon,ntmat_,mi,ttime,time,
     &     iaxial,co,vold
!
      intent(inout) identity,xflow,idirf,nodef,numf,f,df,iplausi,prop
!
      phi=0.d0
      index=ielprop(nelem)
!
      if(iflag.eq.0) then
         identity=.true.
!
         if(nactdog(2,node1).ne.0)then
            identity=.false.
         elseif(nactdog(2,node2).ne.0)then
            identity=.false.
         elseif(nactdog(1,nodem).ne.0)then
            identity=.false.
         endif
!
      elseif(iflag.eq.1)then
!
!        complementing the properties of restrictor elements
!
         if(lakon(nelem)(2:5).eq.'REEX')then
            prop(index+2)=100000*prop(index+1)
         elseif(lakon(nelem)(2:7).eq.'REWAOR')then
            prop(index+1)=100000*prop(index+2)
         elseif(lakon(nelem)(2:5).eq.'REEN')then
            prop(index+1)=100000*prop(index+2)
            prop(index+4)=0.5d0
         endif
!
         isothermal=.false.
         kappa=(cp/(cp-R))
         kp1=kappa+1.d0
         km1=kappa-1.d0
!
!        defining surfaces for branch elements
!
         if(lakon(nelem)(2:6).eq.'REBRJ') then
            if(nelem.eq.nint(prop(index+2))) then
               A1=prop(index+5)
               A2=A1
            elseif(nelem.eq.nint(prop(index+3)))then
               A1=prop(index+6)
               A2=A1
            endif
            zeta=1.d0
         elseif(lakon(nelem)(2:6).eq.'REBRS') then
            if(nelem.eq.nint(prop(index+2))) then
               A1=prop(index+5)
               A2=A1
            elseif(nelem.eq.nint(prop(index+3)))then
               A1=prop(index+6)
               A2=A1
            endif
            zeta=1.d0
         elseif(lakon(nelem)(2:5).eq.'REUS' ) then
!
!           for other Restrictor elements
!
            A1=prop(index+1)
            A2=prop(index+2)
            zeta=prop(index+4)
!
!           change in flow direction
!
            if(v(2,node1).ge.v(2,node2))then
               zeta=prop(index+4)
            else
               zeta=prop(index+7)
               if(zeta.le.0.d0)then
                  zeta=prop(index+4)
               endif
            endif
!
            if(A1.gt.A2) then
               A1=A2
            endif
         else
            A1=prop(index+1)
            A2=prop(index+2)
            zeta=1.d0
         endif
!
         pt1=v(2,node1)
         pt2=v(2,node2)
!
         if(pt1.ge.pt2) then
            inv=1
            Tt1=v(0,node1)-physcon(1)
            Tt2=v(0,node2)-physcon(1)
         else
            inv=-1
            pt1=v(2,node2)
            pt2=v(2,node1)
            Tt1=v(0,node2)-physcon(1)
            Tt2=v(0,node1)-physcon(1)
         endif
!
         pt1pt2=pt1/pt2
         pt2pt1=1/pt1pt2
         km1=kappa-1.d0
         kp1=kappa+1.d0
         kdkm1=kappa/km1
!
         if(.not.isothermal) then
            pt1pt2_crit=(0.5d0*kp1)**(zeta*kdkm1)
         else
            pt1pt2_crit=0.5d0*(3*kappa-1)**(zeta*kdkm1)
         endif
!
         if(pt1pt2.gt.pt1pt2_crit) then
            crit=.true.
            pt1pt2=pt1pt2_crit
         endif
!
         if(A1.le.A2) then
!
            Qred1=dsqrt(kappa/R)*pt1pt2**(-0.5d0*kp1/(kappa*zeta))
     &           *dsqrt(2.d0/km1*(pt1pt2**(km1/(kappa*zeta))-1.d0))
!
            Qred2=pt1pt2*A1/A2*Qred1
!
            if(.not.isothermal) then
               Qred_crit=dsqrt(kappa/R)*(1.d0+0.5d0*km1)
     &              **(-0.5d0*kp1/km1)
            else
               Qred_crit=dsqrt(1/R)*(1+0.5d0*km1/kappa)
     &              **(-0.5d0*kp1/km1)
            endif
!
            if(Qred2.lt.Qred_crit) then
               if((Qred1.gt.Qred_crit).or.(pt1pt2.gt.pt1pt2_crit)) then
                  xflow=inv*A1*pt1*Qred_crit/dsqrt(Tt1)
               else
                  xflow=inv*A1*pt1*Qred1/dsqrt(Tt1)
               endif
            else
               call pt2_lim_calc(pt1,a2,a1,kappa,zeta,pt2_lim)
!
               xflow=inv*A2*pt2_lim*Qred_crit/dsqrt(Tt2)
!
            endif
!
         else
            Qred_crit=dsqrt(kappa/R)*(1.d0+0.5d0*km1)
     &              **(-0.5d0*kp1/km1)
            call pt2_lim_calc(pt1,a2,a1,kappa,zeta,pt2_lim)
!
            xflow=inv*A2*pt2_lim*Qred_crit/dsqrt(Tt2)
         endif
!
         pt2pt1=pt2/pt1
         km1=kappa-1.d0
         kp1=kappa+1.d0
         kdkm1=kappa/km1
         tdkp1=2.d0/kp1
         C2=tdkp1**kdkm1
         if(A1.gt.A2) then
            Aeff=A2
         else
            Aeff=A1
         endif
         if(pt2pt1.gt.C2) then
            xflow=inv*pt1*Aeff*dsqrt(2.d0*kdkm1*pt2pt1**(2.d0/kappa)
     &           *(1.d0-pt2pt1**(1.d0/kdkm1))/r)/dsqrt(Tt1)
         else
            xflow=inv*pt1*Aeff*dsqrt(kappa/r)*tdkp1**(kp1/(2.d0*km1))/
     &           dsqrt(Tt1)
         endif
         if(lakon(nelem)(2:5).ne.'RECO') then
            xflow=0.75d0*xflow
         else
            xflow=xflow
         endif
!
      elseif(iflag.eq.2)then
!
!        complementing the properties of restrictor elements
!
         if(lakon(nelem)(2:5).eq.'REEX')then
            prop(index+2)=100000*prop(index+1)
         elseif(lakon(nelem)(2:7).eq.'REWAOR')then
            prop(index+1)=100000*prop(index+2)
         elseif(lakon(nelem)(2:5).eq.'REEN')then
            prop(index+1)=100000*prop(index+2)
            prop(index+4)=0.5d0
         endif
!
         numf=4
         isothermal=.false.
         pi=4.d0*datan(1.d0)
         kappa=(cp/(cp-R))
         km1=kappa-1.d0
         kp1=kappa+1.d0
         kdkm1=kappa/km1
         kdkp1=kappa/kp1
!
         pt1=v(2,node1)
         pt2=v(2,node2)
!
         if(pt1.ge.pt2) then
            inv=1
         else
            inv=-1
         endif
!
!        defining surfaces and oil properties for branches elements
!
         if(lakon(nelem)(2:6).eq.'REBRJ') then
            if(nelem.eq.nint(prop(index+2))) then
               A1=prop(index+5)
               A2=A1
               xflow_oil=prop(index+9)
               k_oil=nint(prop(index+11))
            elseif(nelem.eq.nint(prop(index+3)))then
               A1=prop(index+6)
               A2=A1
               xflow_oil=prop(index+10)
               k_oil=nint(prop(index+11))
            endif
         elseif(lakon(nelem)(2:6).eq.'REBRS') then
            if(nelem.eq.nint(prop(index+2))) then
               A1=prop(index+5)
               A2=A1
               if(lakon(nelem)(2:8).eq.'REBRSI1') then
                  xflow_oil=prop(index+11)
                  k_oil=nint(prop(index+13))
               else
                  xflow_oil=prop(index+9)
                  k_oil=nint(prop(index+11))
               endif
            elseif(nelem.eq.nint(prop(index+3)))then
               A1=prop(index+6)
               A2=A1
               if(lakon(nelem)(2:8).eq.'REBRSI1') then
                  xflow_oil=prop(index+12)
                  k_oil=nint(prop(index+13))
               else
                  xflow_oil=prop(index+10)
                  k_oil=nint(prop(index+11))
               endif
            endif
         else
!
!           for other Restrictor elements
!
            if(inv.gt.0.d0) then
               A1=prop(index+1)
               A2=prop(index+2)
            else
               A1=prop(index+2)
               A2=prop(index+1)
            endif
!
            if(lakon(nelem)(2:5).eq.'REEL') then
               xflow_oil=prop(index+4)
               k_oil=nint(prop(index+5))
            elseif((lakon(nelem)(2:7).eq.'RELOID').or.
     &              (lakon(nelem)(2:5).eq.'REUS').or.
     &              (lakon(nelem)(2:5).eq.'REEN').or.
     &              (lakon(nelem)(2:5).eq.'REEX').or.
     &              (lakon(nelem)(2:7).eq.'REWAOR').or.
     &              (lakon(nelem)(2:7).eq.'RELOLI')) then
               xflow_oil=prop(index+5)
               k_oil=nint(prop(index+6))
            elseif((lakon(nelem)(2:5).eq.'RECO').or.
     &              (lakon(nelem)(2:7).eq.'REBEMA').or.
     &              (lakon(nelem)(2:7).eq.'REBEMI').or.
     &              (lakon(nelem)(2:8).eq.'REBEIDC')) then
               xflow_oil=prop(index+6)
               k_oil=nint(prop(index+7))
            elseif(lakon(nelem)(2:8).eq.'REBEIDR') then
               xflow_oil=prop(index+8)
               k_oil=nint(prop(index+9))
            endif
         endif
!
         if(pt1.gt.pt2) then
            inv=1
            xflow=v(1,nodem)*iaxial
            Tt1=v(0,node1)-physcon(1)
            Tt2=v(0,node2)-physcon(1)
!
            icase=0
            call ts_calc(xflow,Tt1,pt1,kappa,r,a1,T1,icase)
            call ts_calc(xflow,Tt2,pt2,kappa,r,a2,T2,icase)
!
            nodef(1)=node1
            nodef(2)=node1
            nodef(3)=nodem
            nodef(4)=node2
!
         elseif(pt1.eq.pt2) then
            inv=1
            xflow=v(1,nodem)*iaxial
            Tt1=v(0,node1)-physcon(1)
            Tt2=v(0,node2)-physcon(1)
!
            pt2=pt2-0.01d0*pt2
            icase=0
            call ts_calc(xflow,Tt1,pt1,kappa,r,a1,T1,icase)
            call ts_calc(xflow,Tt2,pt2,kappa,r,a2,T2,icase)
!
            nodef(1)=node1
            nodef(2)=node1
            nodef(3)=nodem
            nodef(4)=node2
!
         else
            inv=-1
            pt1=v(2,node2)
            pt2=v(2,node1)
            xflow=-v(1,nodem)*iaxial
            Tt1=v(0,node2)-physcon(1)
            Tt2=v(0,node1)-physcon(1)
            icase=0
            call ts_calc(xflow,Tt1,pt1,kappa,r,a1,T1,icase)
            call ts_calc(xflow,Tt2,pt2,kappa,r,a2,T2,icase)
            nodef(1)=node2
            nodef(2)=node2
            nodef(3)=nodem
            nodef(4)=node1
         endif
!
         idirf(1)=2
         idirf(2)=0
         idirf(3)=1
         idirf(4)=2
!
!        calculation of the dynamic viscosity
!
         if(lakon(nelem)(2:3).eq.'RE') then
            icase=0
         endif
!
         if(dabs(dvi).lt.1d-30) then
            write(*,*) '*ERROR in restrictor: '
            write(*,*) '       no dynamic viscosity defined'
            write(*,*) '       dvi= ',dvi
            call exit(201)
         endif
!
!        Reynolds number calculation
!
         if(lakon(nelem)(2:5).eq.'REBR') then
            d=dsqrt(4d0*A1/Pi)
            reynolds=dabs(xflow)*d/(dvi*A1)
         else
            d=prop(index+3)
            if(A1.le.A2) then
               reynolds=dabs(xflow)*d/(dvi*A1)
            else
               reynolds=dabs(xflow)*d/(dvi*A2)
            endif
         endif

         if(xflow_oil.lt.1.d-10) then
            xflow_oil=0.d0
         endif
         if(lakon(nelem)(2:7).eq.'REBEMI') then
!
!           BEND MILLER with oil
!
            if(xflow_oil.ne.0.d0) then
!
               call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow,
     &              xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop,
     &              v,dvi,cp,r,k_oil,phi,zeta,nshcon,nrhcon,
     &              shcon,rhcon,ntmat_,mi,iaxial)
!
               zeta=phi*zeta
            else

               call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta,
     &              isothermal,kon,ipkon,R,Kappa,v,mi,iaxial)
               phi=1.d0
            endif
         elseif(lakon(nelem)(2:7).eq.'RELOID') then
!
!           long orifice idelchick with oil
!
            if(xflow_oil.ne.0.d0) then
!
               call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow,
     &              xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop,
     &              v,dvi,cp,r,k_oil,phi,zeta,nshcon,nrhcon,
     &              shcon,rhcon,ntmat_,mi,iaxial)
               zeta=phi*zeta

            else

               call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta,
     &              isothermal,kon,ipkon,R,Kappa,v,mi,iaxial)
               phi=1.d0
            endif
!
         else
!
!           every other zeta elements with/without oil
!
            if(xflow_oil.ne.0.d0) then
               call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow,
     &              xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop,
     &              v,dvi,cp,r,k_oil,phi,zeta,nshcon,nrhcon,
     &              shcon,rhcon,ntmat_,mi,iaxial)
               call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta,
     &              isothermal,kon,ipkon,R,Kappa,v,mi,iaxial)
               zeta=phi*zeta
            else
               phi=1.d0
               call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta,
     &              isothermal,kon,ipkon,R,Kappa,v,mi,iaxial)
               zeta=phi*zeta
            endif
         endif
!
         if(dabs(zeta).lt.1.d-10) zeta=0.d0
!
         if(zeta.lt.0.d0) then
            pt1=v(2,node1)
            pt2=v(2,node2)
            xflow=v(1,nodem)*iaxial
            Tt2=v(0,node2)
            Tt1=v(0,node1)
           call ts_calc(xflow,Tt1,pt1,kappa,r,A1,T1,icase)
           call ts_calc(xflow,Tt2,pt2,kappa,r,A2,T2,icase)
!
            nodef(1)=node1
            nodef(2)=node1
            nodef(3)=nodem
            nodef(4)=node2
!
         endif
!
         if(.not.isothermal) then
            pt1pt2_crit=(0.5d0*kp1)**(zeta*kdkm1)
         else
            pt1pt2_crit=0.5d0*(3*kappa-1)**(zeta*kdkm1)
         endif
         pt1pt2=pt1/pt2
!
!        Mach number caclulation
!
         M1=dsqrt(2d0/km1*(Tt1/T1-1.d0))
         if((1.d0-M1).le.1.d-6) then
            if(zeta.gt.0.d0) then
               call limit_case_calc(a2,pt1,Tt2,xflow,zeta,r,kappa,
     &              pt2_lim,M2)
!
            endif
         else
            M2=dsqrt(2d0/km1*(Tt2/T2-1.d0))
         endif
!
!        Section A1 smaller than or equal to section A2
!        or for all BRANCHES ELEMENTS
!
         if(A1.le.A2) then
!
!           definition of the reduced mass flows
!
            if(zeta.gt.0.d0) then
!
               Qred1=dsqrt(kappa/R)*pt1pt2**(-0.5d0*kp1/(kappa*zeta))
     &              *dsqrt(2.d0/km1*(pt1pt2**(km1/(kappa*zeta))-1.d0))
!
            elseif(zeta.lt.0.d0) then
!
               Qred1=dabs(xflow)*dsqrt(Tt1)/(pt1*A1)
!
            endif
!
            Qred2=pt1pt2*A1/A2*Qred1
!
            if(.not.isothermal) then
               Qred_crit=dsqrt(kappa/R)*(1.d0+0.5d0*km1)
     &              **(-0.5d0*kp1/km1)
            else
               Qred_crit=dsqrt(1/R)*(1+0.5d0*km1/kappa)
     &              **(-0.5d0*kp1/km1)
            endif
!
!           icase zeta greater than zero
!
            if(zeta.gt.0.d0) then
!
!              definition of the coefficients
!
               if((pt1pt2.ge.0.9999999999d0).and.
     &              (pt1pt2.le.1.000000000111111d0))then
                  pt1=1.0001d0*pt2
                  pt1pt2=pt1/pt2
               endif
!
               sqrt=dsqrt(R*Tt1/kappa)
               expon1=-0.5d0*kp1/(zeta*kappa)
               fact1=pt1pt2**expon1
               expon2=km1/(zeta*kappa)
               fact2=pt1pt2**expon2
               expon3=1.d0/(zeta*kappa)
               root=2d0/km1*(fact2-1.d0)
!
               if(Qred2.lt.Qred_crit) then
!
                  if((Qred1.lt.Qred_crit)
     &                 .and.(pt1pt2.lt.pt1pt2_crit))then
!
!                    section 1 is not critical
!
!                    residual
!
                     f=xflow*sqrt/(A1*pt1)-fact1*dsqrt(root)
!
!                    pressure node1
!
                     df(1)=-xflow*sqrt/(A1*pt1**2)+
     &                    fact1/pt1*dsqrt(root)
     &                    *(-expon1-expon3*fact2/root)
!
!                    temperature node1
!
                     df(2)=0.5d0*xflow*dsqrt(R/(kappa*Tt1))/(A1*pt1)
!
!                    mass flow
!
                     df(3)=inv*sqrt/(A1*pt1)
!
!                    pressure node2
!
                     df(4)=fact1/pt2*dsqrt(root)*
     &                    (expon1+expon3*fact2/root)
!
                  else
!
!                    section1 is critical
!
                     f=xflow*sqrt/(pt1*A1)-dsqrt(R/kappa)*qred_crit
!
!                    pressure node1
!
                     df(1)=-xflow*sqrt/(A1*pt1**2)
!
!                    temperature node1
!
                     df(2)=0.5d0*xflow*dsqrt(R/kappa)
     &                    /(pt1*A1*dsqrt(Tt1))
!
!                    mass flow
!
                     df(3)=inv*sqrt/(A1*pt1)
!
!                    pressure node2
!
                     df(4)=0.d0
!
                  endif
!
               else
!
!                 section A2 critical
!
                  call pt2_lim_calc(pt1,a2,a1,kappa,zeta,pt2_lim)
                  pt1pt2=pt1/pt2_lim
!
                  fact1=pt1pt2**expon1
!
                  fact2=pt1pt2**expon2
!
                  root=2d0/km1*(fact2-1.d0)
!
                  f=xflow*sqrt/(A1*pt1)-fact1*dsqrt(root)
!
!                 pressure node1
!
                  df(1)=-xflow*sqrt/(A1*pt1**2)+
     &                 fact1/pt1*dsqrt(root)
     &                 *(-expon1-expon3*fact2/root)
!
!                 temperature node1
!
                  df(2)=0.5d0*xflow*dsqrt(R/(kappa*Tt1))/(A1*pt1)
!
!                 mass flow
!
                  df(3)=inv*sqrt/(A1*pt1)
!
!                 pressure node2
!
                  df(4)=0
!
               endif
!
!              icase zeta less than zero
!
            elseif(zeta.lt.0.d0) then
!
               expon1=-kp1/(zeta*kappa)
               fact1=pt1pt2**expon1
               expon2=km1/(zeta*kappa)
               fact2=pt1pt2**expon2
               expon3=1.d0/(zeta*kappa)
               root=2d0/km1*(fact2-1.d0)
!
               if(Qred1.lt.Qred_crit) then
!
!                 section 1 is not critical
!
!                 residual
!
                  f=xflow**2*R*Tt1/(A1**2*pt1**2*Kappa)
     &                 -fact1*root
!
!                 pressure node1
!
                  df(1)=-2*xflow**2*R*Tt1/(A1**2*pt1**3*Kappa)
     &                 -1/pt1*fact1*(expon1*root
     &                 +2/(zeta*kappa)*fact2)
!
!                 temperature node1
!
                  df(2)=xflow**2*R/(A1**2*pt1**2*Kappa)
!
!                 mass flow
!
                  df(3)=2*xflow*R*Tt1/(A1**2*pt1**2*Kappa)
!
!                 pressure node2
!
                  df(4)=-(1/pt2*fact1)
     &                 *(-expon1*root-2/(zeta*kappa)*fact2)
!
               else
!
!                 section1 is critical
!
                  f=xflow**2*R*Tt1/(A1**2*pt1**2*Kappa)
     &                 -R/kappa*qred_crit**2
!
!                 pressure node1
!
                  df(1)=-2*xflow**2*R*Tt1/(A1**2*pt1**3*kappa)
!
!                 temperature node1
!
                  df(2)=xflow**2*R/(A1**2*pt1**2*Kappa)
!
!                 mass flow
!
                  df(3)=2*xflow*R*Tt1/(A1**2*pt1**2*Kappa)
!
!                 pressure node2
!
                  df(4)=0.d0
!
               endif
!
            elseif(zeta.eq.0.d0) then
!
!              zeta = 0
!
               f=pt1/pt2-1.d0
!
               df(1)=1/pt2
               df(2)=0.d0
               df(3)=0.d0
               df(4)=-pt1/pt2**2
!
            endif
!
         else
!
!           A1 greater than A2
!
            Qred2=dabs(xflow)*dsqrt(Tt2)/(A2*pt2)
!
            Qred1=1/pt1pt2*A2/A1*Qred2
!
            Qred_crit=dsqrt(kappa/R)*(1.d0+0.5d0*km1)
     &           **(-0.5d0*kp1/km1)
!
!           definition of the coefficients
!
            if(zeta.gt.0.d0) then
!
               sqrt=dsqrt(R*Tt1/kappa)
!
               if((pt1pt2.ge.0.9999999999d0).and.
     &              (pt1pt2.le.1.000000000111111d0))then
                  pt1=1.0001d0*pt2
                  pt1pt2=pt1/pt2
               endif
!
               expon1=-0.5d0*kp1/(zeta*kappa)
               fact1=pt1pt2**expon1
               expon2=km1/(zeta*kappa)
               fact2=pt1pt2**expon2
               expon3=1.d0/(zeta*kappa)
               root=2d0/km1*(fact2-1.d0)
!
               if(pt1pt2.ge.pt1pt2_crit) then
                  pt1pt2=pt1pt2_crit
                  pt2=pt1/pt1pt2_crit
               endif
!
               if((Qred2.lt.Qred_crit)
     &              .and.(pt1/pt2.lt.pt1pt2_crit)) then
!
!                 section 2 is not critical
!
!                 residual
!
                  f=xflow*sqrt/(A2*pt2)-fact1*dsqrt(root)
!
!                 pressure node1
!
                  df(1)=-fact1/pt1*dsqrt(root)
     &                 *(expon1+0.5d0*dsqrt(2/km1)*expon2*fact2/root)
!
!                 temperature node1
!
                  df(2)=0.5d0*xflow*sqrt/(A2*pt2*Tt1)
!
!                 mass flow
!
                  df(3)=inv*sqrt/(A2*pt2)
!
!                 pressure node2
!
                  df(4)=-xflow*sqrt/(A2*pt2**2)
     &                 -fact1/pt2*dsqrt(root)*
     &                 (-expon1-0.5d0*dsqrt(2/km1)*expon2*fact2/root)
!
               else
                  write(*,*)
     &              '*WARNING in restrictor: A1 greater than A2'
                  write(*,*) '         critical flow in element',nelem
!
!                 section2 is critical
!
                  pt2=pt1/pt1pt2_crit
!
                  f=xflow*dsqrt(Tt1)/(pt2*A2)-qred_crit
!
!                 pressure node1
!
                  df(1)=0
!
!                 temperature node1
!
                  df(2)=0.5d0*xflow/(A2*pt2*dsqrt(Tt2))
!
!                 mass flow
!
                  df(3)=inv*dsqrt(Tt1)/(A2*pt2)
!
!                 pressure node2
!
                  df(4)=-xflow*dsqrt(Tt1)/(A2*pt2**2)
!
               endif
!
            elseif(zeta.eq.0.d0) then
!
               Qred1=dabs(xflow)*dsqrt(Tt1*kappa/R)/(A1*pt1)
               Qred2=dabs(xflow)*dsqrt(Tt2*kappa/R)/(A2*pt2)
               Qred_crit=dsqrt(kappa/R)*(1.d0+0.5d0*km1)
     &              **(-0.5d0*kp1/km1)
!
               f=pt1/pt2-1.d0
!
               df(1)=1/pt2
!
               df(2)=0.d0
!
               df(3)=0.d0
!
               df(4)=-pt1/pt2**2
!
            endif
         endif
!
      elseif((iflag.eq.3).or.(iflag.eq.4)) then
!
!        complementing the properties of restrictor elements
!
         if(lakon(nelem)(2:5).eq.'REEX')then
            prop(index+2)=100000*prop(index+1)
         elseif(lakon(nelem)(2:7).eq.'REWAOR')then
            prop(index+1)=100000*prop(index+2)
         elseif(lakon(nelem)(2:5).eq.'REEN')then
            prop(index+1)=100000*prop(index+2)
            prop(index+4)=0.5d0
         endif
!
         isothermal=.false.
         pi=4.d0*datan(1.d0)
         kappa=(cp/(cp-R))
         km1=kappa-1.d0
         kp1=kappa+1.d0
         kdkm1=kappa/km1
         kdkp1=kappa/kp1
!
         pt1=v(2,node1)
         pt2=v(2,node2)
         if(pt1.ge.pt2) then
            inv=1
         else
            inv=-1
         endif
!
!        defining surfaces for branches elements
!
         if(lakon(nelem)(2:6).eq.'REBRJ') then
            if(nelem.eq.nint(prop(index+2))) then
               A1=prop(index+5)
               A2=A1
               xflow_oil=prop(index+9)
               k_oil=nint(prop(index+11))
            elseif(nelem.eq.nint(prop(index+3)))then
               A1=prop(index+6)
               A2=A1
               xflow_oil=prop(index+10)
               k_oil=nint(prop(index+11))
            endif
         elseif(lakon(nelem)(2:6).eq.'REBRS') then
            if(nelem.eq.nint(prop(index+2))) then
               A1=prop(index+5)
               A2=A1
               if(lakon(nelem)(2:8).eq.'REBRSI1') then
                  xflow_oil=prop(index+11)
                  k_oil=nint(prop(index+13))
               else
                  xflow_oil=prop(index+9)
                  k_oil=nint(prop(index+11))
               endif
            elseif(nelem.eq.nint(prop(index+3)))then
               A1=prop(index+6)
               A2=A1
               if(lakon(nelem)(2:8).eq.'REBRSI1') then
                  xflow_oil=prop(index+12)
                  k_oil=nint(prop(index+13))
               else
                  xflow_oil=prop(index+10)
                  k_oil=nint(prop(index+11))
               endif
            endif
         else
!
!           for other Restrictor elements
!
            A1=prop(index+1)
            A2=prop(index+2)
            if(lakon(nelem)(2:5).eq.'REEL') then
               xflow_oil=prop(index+4)
               k_oil=nint(prop(index+5))
            elseif((lakon(nelem)(2:7).eq.'RELOID').or.
     &              (lakon(nelem)(2:5).eq.'REUS').or.
     &              (lakon(nelem)(2:5).eq.'REEN').or.
     &              (lakon(nelem)(2:5).eq.'REEX').or.
     &              (lakon(nelem)(2:7).eq.'REWAOR').or.
     &              (lakon(nelem)(2:7).eq.'RELOLI')) then
               xflow_oil=prop(index+5)
               k_oil=nint(prop(index+6))
            elseif((lakon(nelem)(2:5).eq.'RECO').or.
     &              (lakon(nelem)(2:7).eq.'REBEMA').or.
     &              (lakon(nelem)(2:7).eq.'REBEMI').or.
     &              (lakon(nelem)(2:8).eq.'REBEIDC')) then
               xflow_oil=prop(index+6)
               k_oil=nint(prop(index+7))
            elseif(lakon(nelem)(2:8).eq.'REBEIDR') then
               xflow_oil=prop(index+8)
               k_oil=nint(prop(index+9))
            endif
         endif
!
         if(pt1.ge.pt2) then
            inv=1
            xflow=v(1,nodem)*iaxial
            Tt1=v(0,node1)-physcon(1)
            Tt2=v(0,node2)-physcon(1)
            icase=0
            call ts_calc(xflow,Tt1,pt1,kappa,r,a1,T1,icase)
            call ts_calc(xflow,Tt2,pt2,kappa,r,a2,T2,icase)
!
         else
            inv=-1
            pt1=v(2,node2)
            pt2=v(2,node1)
            xflow=-v(1,nodem)*iaxial
            Tt1=v(0,node2)-physcon(1)
            Tt2=v(0,node1)-physcon(1)
            icase=0
            call ts_calc(xflow,Tt1,pt1,kappa,r,a1,T1,icase)
            call ts_calc(xflow,Tt2,pt2,kappa,r,a2,T2,icase)
!
         endif
!
!        calculation of the dynamic viscosity
!
         if(lakon(nelem)(2:3).eq.'RE') then
            icase=0
         elseif(lakon(nelem)(2:5).eq.'REEX') then
            if(lakon(nint(prop(index+4)))(2:6).eq.'GAPFA') then
               icase=0
            elseif(lakon(nint(prop(index+4)))(2:6).eq.'GAPFI') then
               icase=1
            endif
         endif
!
         if(dabs(dvi).lt.1d-30) then
            write(*,*) '*ERROR in restrictor: '
            write(*,*) '       no dynamic viscosity defined'
            write(*,*) '       dvi= ',dvi
            call exit(201)
         endif
!
!        Reynolds number calculation
!
         if(lakon(nelem)(2:5).eq.'REBR') then
            d=dsqrt(4d0*A1/Pi)
            reynolds=dabs(xflow)*d/(dvi*A1)
         else
            d=prop(index+3)
            if(A1.le.A2) then
               reynolds=dabs(xflow)*d/(dvi*A1)
            else
               reynolds=dabs(xflow)*d/(dvi*A2)
            endif
         endif
!
         if(xflow_oil.lt.1.d-10) then
            xflow_oil=0.d0
         endif
!
!        BEND MILLER with oil
!
         if(lakon(nelem)(2:7).eq.'REBEMI') then
            if(xflow_oil.ne.0.d0) then
               call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow,
     &              xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop,
     &              v,dvi,cp,r,k_oil,phi,zeta,nshcon,nrhcon,
     &              shcon,rhcon,ntmat_,mi,iaxial)

               call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta,
     &              isothermal,kon,ipkon,R,Kappa,v,mi,iaxial)
!
               zeta_phi=phi*zeta
            else
!
               call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta,
     &              isothermal,kon,ipkon,R,Kappa,v,mi,iaxial)
               phi=1.d0
               zeta_phi=phi*zeta
!
            endif
         elseif(lakon(nelem)(2:7).eq.'RELOID') then
!
!           long  orifice in a wall with oil after Idelchik
!
            if(xflow_oil.ne.0.d0) then
               call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow,
     &              xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop,
     &              v,dvi,cp,r,k_oil,phi,zeta,nshcon,nrhcon,
     &              shcon,rhcon,ntmat_,mi,iaxial)
!
               zeta_phi=phi*zeta
            else
!
               call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta,
     &              isothermal,kon,ipkon,R,Kappa,v,mi,iaxial)
               phi=1.d0
               zeta_phi=phi*zeta
            endif
!
         else
!
!           every other zeta elements with/without oil
!
            if(xflow_oil.ne.0.d0) then
               call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow,
     &              xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop,
     &              v,dvi,cp,r,k_oil,phi,zeta,nshcon,nrhcon,
     &              shcon,rhcon,ntmat_,mi,iaxial)
!
               call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta,
     &              isothermal,kon,ipkon,R,Kappa,v,mi,iaxial)
!
               zeta_phi=phi*zeta
            else
               phi=1.d0
               call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta,
     &              isothermal,kon,ipkon,R,Kappa,v,mi,iaxial)
               zeta_phi=phi*zeta
            endif
         endif
!
         if(zeta.le.0.d0) then
            pt1=v(2,node1)
            pt2=v(2,node2)
            xflow=v(1,nodem)*iaxial
            Tt1=v(0,node1)
            Tt2=v(0,node2)
!
         endif
!
         if(.not.isothermal) then
            pt1pt2_crit=(0.5d0*kp1)**(zeta*kdkm1)
         else
            pt1pt2_crit=0.5d0*(3*kappa-1)**(zeta*kdkm1)
         endif
         pt1pt2=pt1/pt2
!
!        Mach number calculation
!
         M1=dsqrt(2d0/km1*(Tt1/T1-1.d0))
         if((1.d0-M1).le.1d-3) then

            if(zeta.gt.0.d0)then
               if(xflow_oil.eq.0.d0) then
                  call limit_case_calc(a2,pt1,Tt2,xflow,zeta,r,kappa,
     &                 pt2_lim,M2)
               else
                  call limit_case_calc(a2,pt1,Tt2,xflow,zeta_phi,r,kappa
     &                 ,pt2_lim,M2)
               endif
            endif
         else
            M2=dsqrt(2d0/km1*(Tt2/T2-1.d0))
         endif
!
         if(iflag.eq.3) then
            write(1,*) ''
            write(1,55) ' from node ',node1,
     &           ' to node ', node2,' :   air massflow rate = '
     &           ,xflow,' '
     &           , ' , oil massflow rate = ',xflow_oil,' '
!
            if(lakon(nelem)(4:5).ne.'BR') then
!
!              for restrictors
!
               if(inv.eq.1) then
               write(1,56)'       Inlet node ',node1,' :    Tt1=  ',Tt1,
     &              '  , Ts1 = ',T1,'  , Pt1 = ',pt1,
     &              '  , M1 = ',M1
                write(1,*)'             Element ',nelem,lakon(nelem)
                write(1,57)'             dyn.visc. = ',dvi,' , Re = '
     &           ,reynolds
                write(1,58)'             PHI = ',phi,' , ZETA = ',zeta,
     &        ' , ZETA_PHI = ',phi*zeta
                write(1,56)'      Outlet node ',node2,' :   Tt2 = ',
     &              Tt2,
     &              ' , Ts2 = ',T2,'  , Pt2 = ',pt2,
     &              '  , M2= ',M2
!
             elseif(inv.eq.-1) then
                write(1,56)'       Inlet node ',node2,' :    Tt1= ',Tt1,
     &              ' , Ts1= ',T1,' , Pt1= ',pt1,
     &              ' , M1= ',M1
                write(1,*)'            Element ',nelem,lakon(nelem)
                write(1,57)'             dyn.visc. =',dvi,'  , Re = '
     &           ,reynolds
                write(1,58)'             PHI = ',phi,' , ZETA = ',zeta,
     &         ' , ZETA_PHI = ',phi*zeta
                write(1,56)'      Outlet node ',node1,' :   Tt2 = ',
     &              Tt2,
     &              '  , Ts2 = ',T2,'  , Pt2 = ',pt2,
     &              '  , M2 = ',M2
             endif
          else
!
!            for branches
!
             if(inv.eq.1) then
                write(1,56)'       Inlet node ',node1,' :    Tt1 = ',
     &              Tt1,
     &              '  , Ts1 = ',T1,'  , Pt1 = ',pt1,
     &              '  , M1 = ',M1
                write(1,*)'             Element ',nelem,lakon(nelem)
                write(1,57)'             dyn.visc. = ',dvi,' , Re = '
     &           ,reynolds
                write(1,58)'             PHI = ',phi,' , ZETA = ',zeta,
     &        ' , ZETA_PHI = ',phi*zeta
                write(1,56)'      Outlet node ',node2,' :   Tt2 = ',
     &              Tt2,
     &              '  , Ts2 = ',T2,'  , Pt2 = ',pt2,
     &              '  , M2 = ',M2
!
             elseif(inv.eq.-1) then
                write(1,56)'       Inlet node ',node2,' :    Tt1 = ',
     &              Tt1,
     &              ', Ts1 = ',T1,' , Pt1 = ',pt1,
     &              '  , M1 = ',M1
                write(1,*)'             Element ',nelem,lakon(nelem)
                write(1,57)'             dyn.visc. =',dvi,'  , Re = '
     &           ,reynolds
                write(1,58)'             PHI = ',phi,' , ZETA = ',zeta,
     &' , ZETA_PHI = ',phi*zeta
                write(1,56)'      Outlet node ',node1,' :   Tt2 = ',
     &              Tt2,
     &              '  , Ts2 = ',T2,'  , Pt2 = ',pt2,
     &              '  , M2 = ',M2
             endif
          endif
!
       endif
      endif
!
 55   format(1x,a,i6,a,i6,a,e11.4,a,a,e11.4,a)
 56   format(1x,a,i6,a,e11.4,a,e11.4,a,e11.4,a,e11.4)
 57   format(1x,a,e11.4,a,e11.4)
 58   format(1x,a,e11.4,a,e11.4,a,e11.4)
!
      xflow=xflow/iaxial
      df(3)=df(3)*iaxial
!
      return
      end


!***************************************************************************************************************************
! This module is intended to calculate environment effects in the plant
! 12/09/2017 converted from UTF-8 to ANSI
! Atributes:
!
! Object functions:
!
! Static functions:
!
! Authors
! @danipilze
!*********

    Module YCA_Control_VPDEffect !Module of environment
    type VPDEffect_type

        real, private :: VPDThreshold_ =  0                ! VPD Threshold to start reducing stomatal conductance (KPa)
        real, private :: VPDSensitivity_ =  0              ! Plant sensitivity to VPD (fraction/Kpa)
        real, private :: stomatalConductance_ =  1         ! Current stomatal conductance

    contains

        procedure, pass (this) :: getVPDThreshold
        procedure, pass (this) :: setVPDThreshold
        procedure, pass (this) :: getVPDSensitivity
        procedure, pass (this) :: setVPDSensitivity
        procedure, pass (this) :: getStomatalConductance
        procedure, pass (this) :: setStomatalConductance
        procedure, pass (this) :: affectStomatalConductance
        procedure, pass (this) :: affectStomatalConductance_restricted

    end Type VPDEffect_type

    ! interface to reference the constructor
    interface VPDEffect_type
        module procedure VPDEffect_type_constructor
    end interface VPDEffect_type

    contains

    ! constructor for the type
    type (VPDEffect_type) function VPDEffect_type_constructor(VPDThreshold, VPDSensitivity)
        implicit none
        real, intent (in) :: VPDThreshold, VPDSensitivity
        VPDEffect_type_constructor%VPDThreshold_ = VPDThreshold
        VPDEffect_type_constructor%VPDSensitivity_ = VPDSensitivity
        VPDEffect_type_constructor%stomatalConductance_= 1

    end function VPDEffect_type_constructor

    !-------------------------------------------
    ! OBJECT FUNCTIONS
    !-------------------------------------------

    ! resets the stomatal conductante to the maximum fraction
    subroutine resetStomatalConductance(this)
        implicit none
        class (VPDEffect_type), intent(inout) :: this
        this%StomatalConductance_ = 1

    end subroutine resetStomatalConductance

    ! retrieves stomatal conductance based on VPD
    real function affectStomatalConductance(this, VPD)
        implicit none
        class (VPDEffect_type), intent(inout) :: this
        real, intent(in) :: VPD

        affectStomatalConductance = affectStomatalConductance_restricted(this, VPD, 1.0)        ! running with the maximum value (1.0)

    end function affectStomatalConductance

    ! retrieves stomatal conductance based on VPD with restriction
    ! limit from 0.0 to 1.0
    real function affectStomatalConductance_restricted(this, VPD, limit)
        implicit none
        class (VPDEffect_type), intent(inout) :: this
        real, intent(in) :: VPD, limit
        real :: value

        value = calculateStomatalConductance(this%stomatalConductance_, VPD, this%VPDThreshold_, this%VPDSensitivity_, AMIN1(1.0, limit))
        call this%setStomatalConductance(value)
        affectStomatalConductance_restricted = value

    end function affectStomatalConductance_restricted

    !-------------------------------------------
    ! STATIC FUNCTIONS
    !-------------------------------------------

    ! calculates stomatal conductance acording to the VPD
    ! limit is 1.0 when there is no restrictions                                                ! fraction
    real function calculateStomatalConductance(previousStomatalConductance, VPD, VPDThreshold, VPDSensitivity, limit)
        implicit none
        real, intent (in) :: previousStomatalConductance, VPD, VPDThreshold, VPDSensitivity, limit
        real :: value = 0

        if(VPD > VPDThreshold) then
            ! y = mx + b
            ! x = VPD-VPDThreshold
            ! m = VPDSensitivity
            ! b = limit
             value =  (VPDSensitivity * (VPD-VPDThreshold)) + limit
                if(value < 0) then
                    value = 0
                end if
        else
            value = limit
        end if

        value = AMIN1(value, previousStomatalConductance) ! never increase

        calculateStomatalConductance = value

    end function calculateStomatalConductance

    !-------------------------------------------
    ! GETTERS AND SETTERS
    !------------------------------------------
    ! get VPDTreshold
    real function getVPDThreshold(this)
        implicit none
        class (VPDEffect_type), intent(in) :: this

        getVPDThreshold = this%VPDThreshold_
    end function getVPDThreshold

    ! set VPDTreshold
    subroutine setVPDThreshold(this, VPDThreshold)
        implicit none
        class (VPDEffect_type), intent(inout) :: this
        real, intent (in) :: VPDThreshold

        this%VPDThreshold_ = VPDThreshold
    end subroutine setVPDThreshold

    ! get VPDSensitivity
    real function getVPDSensitivity(this)
        implicit none
        class (VPDEffect_type), intent(in) :: this

        getVPDSensitivity = this%VPDSensitivity_
    end function getVPDSensitivity

    ! set VPDSensitivity
    subroutine setVPDSensitivity(this, VPDSensitivity)
        implicit none
        class (VPDEffect_type), intent(inout) :: this
        real, intent (in) :: VPDSensitivity

        this%VPDSensitivity_ = VPDSensitivity
    end subroutine setVPDSensitivity

    ! get stomatal conductance
    real function getStomatalConductance(this)
        implicit none
        class (VPDEffect_type), intent(in) :: this

        getStomatalConductance = this%stomatalConductance_
    end function getStomatalConductance

    ! set stomatal conductance
    subroutine setStomatalConductance(this, stomatalConductance)
        implicit none
        class (VPDEffect_type), intent(inout) :: this
        real, intent (in) :: stomatalConductance

        this%stomatalConductance_ = stomatalConductance
    end subroutine setStomatalConductance

END Module YCA_Control_VPDEffect


c
c     version 1.2  Mar 1992
c
c     ----------------------------------------------------------------
c     |                                                              |
c     |            ***********  F T E S T  ************              |
c     |                                                              |
c     |            Compute the significance of two given             |
c     |             chi-squared values uisng the F-test              |
c     |                                                              |
c     |                   Written by C. A. Zelt                      |
c     |                                                              |
c     |                Geological Survey of Canada                   |
c     |                  Ottawa, Canada K1A 0Y3                      |
c     |                                                              |
c     ----------------------------------------------------------------
c
c
      program main
c
      data pmin/.05/
c
      write(6,*) 'Enter chi-squared and number of points'
      read(5,*) chi1,n1
      write(6,*) 'Enter chi-squared and number of points'
      read(5,*) chi2,n2
c
      if(chi1.gt.chi2) then
        f=chi1/chi2
        df1=n1-1
        df2=n2-1
      else
        f=chi2/chi1
        df1=n2-1
        df2=n1-1
      end if
c
      prob=betai(0.5*df2,0.5*df1,df2/(df2+df1*f))+
     +     (1.-betai(0.5*df1,0.5*df2,df1/(df1+df2/f)))
c
      write(6,5) f,(1.-prob)*100.
5     format(/'F = ',f8.3//'There is a ',
     + f6.2,'% chance of significantly different variances'//)
c
      if(prob.lt.pmin) then
        write(6,15)
15      format('===>  models are significantly different'//)
      else
        write(6,25)
25      format('===>  models are NOT significantly different'//)
      end if
c
      stop
      end
c
c     ---------------------------------------------------------------------
c
      function betai(a,b,x)
c
c     Returns the incomplete beta function
c
      if(x.lt.0..or.x.gt.1.) then
        write(6,*) '***  bad argument x in betai  ***'
        stop
      end if
c
      if(x.eq.0..or.x.eq.1.) then
        bt=0.
      else
        bt=exp(gammln(a+b)-gammln(a)-gammln(b)+
     +     a*alog(x)+b*alog(1.-x))
      end if
c
      if(x.lt.(a+1.)/(a+b+2.)) then
        betai=bt*betacf(a,b,x)/a
      else
        betai=1.-bt*betacf(b,a,1.-x)/b
      end if
c
      return
      end
c
c     ---------------------------------------------------------------------
c
      function betacf(a,b,x)
c
c     continued fraction for incomplete beta function used by betai
c
      parameter(itmax=100, eps=3.e-7)
c
      am=1.
      bm=1.
      az=1.
      qab=a+b
      qap=a+1.
      qam=a-1.
      bz=1.-qab*x/qap
c
      do 10 m=1,itmax
         em=m
         tem=em+em
         d=em*(b-m)*x/((qam+tem)*(a+tem))
         ap=az+d*am
         bp=bz+d*bm
         d=-(a+em)*(qab+em)*x/((a+tem)*(qap+tem))
         app=ap+d*az
         bpp=bp+d*bz
         aold=az
         am=ap/bpp
         bm=bp/bpp
         az=app/bpp
         bz=1.
         if(abs(az-aold).lt.eps*abs(az)) go to 1
10    continue
c
      write(6,*) '***  a or b too big or itmax too small  ***'
      stop
c
1     betacf=az
c
      return
      end
c
c     ---------------------------------------------------------------------
c
      function gammln(xx)
c
c     Returns the value of ln(gamma function) for xx>1
c
      real*8 cof(6),stp,half,one,fpf,x,tmp,ser
      data cof,stp/76.18009173d0,-86.50532033d0,24.01409822d0,
     +    -1.231739516d0,.120858003d-2,-.536382d-5,2.50662827465d0/
      data half,one,fpf/0.5d0,1.0d0,5.5d0/
c
      if(xx.lt.1.) then
        write(6,*) '***  argument too small for gammln  ***'
        stop
      end if
c
      x=xx-one
      tmp=x+fpf
      tmp=(x+half)*log(tmp)-tmp
      ser=one
c
      do 10 j=1,6
         x=x+one
         ser=ser+cof(j)/x
10    continue
c
      gammln=tmp+log(stp*ser)
c
      return
      end


! Example of named labels used with EXIT statement.
   S1:  DO
           IF (X > Y ) THEN
                 Z = X
                 EXIT S1
           END IF
           CALL NEW(X)
        END DO

        N = 0
 LOOP1: DO I = 1, 10
           J= I
 LOOP2:       DO K =1, 5
                 L = K
                 N = N +1
              END DO LOOP2
        END DO LOOP1

      jmax=n-1
      outer: do i=1,n-1
        temp=1.e38
        inner: do j=1,jmax
          if(x(j).gt.x(j+1)) cycle inner
            temp=x(j)
            x(j)=x(j+1)
            x(j+1)=temp
            itemp=iy(j)
            iy(j)=iy(j+1)
            iy(j+1)=itemp
        end do inner
        if(temp.eq.1.e38) exit outer
        jmax=jmax-1
      end do outer
end


! ##############################################################################
! rng

module rng

  use types ! set type precision

  ! user has default access to all functions
  public

  ! ############################################################################
  ! set the defualt rnadom number generator

  interface ran
    module procedure ran2
  end interface

  integer, parameter :: state_size = 35

  ! ############################################################################

  contains

    ! ##########################################################################
    ! ##########################################################################

    function ran0(state) result(o)
      ! Numerical Recipes in Fortran77 Ch7.1 <ran0>
      ! Numerical Recipes in C 2Ed Ch7.1 <ran0>

      integer(dp) state(1), k
      real(dp) o

      integer(dp), parameter :: ia = 16807, im = 2147483647, iq = 127773, &
        ir = 2836, mask = 123459876
      real(dp), parameter :: am = 1. / im

      state(1) = ieor(state(1), mask)
      k = state(1) / iq
      state(1) = ia * (state(1) - k * iq) - ir * k
      if (state(1).lt.0) state(1) = state(1) + im
      o = am * state(1)
      state(1) = ieor(state(1), mask)

      return
    end

    subroutine ran0v(state, new_state, output, n)
      ! wrapper for python

      integer(dp) state(1), new_state(1) ! seed size
      real(dp) output(n)

      !f2py intent(in) :: state, n
      !f2py intent(out) :: new_state, output

      integer(sp) :: n, remainder
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one) ! x % 2n == x & (2n - 1)
      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1
          output(i+j-1) = ran0(state) ! function reference
        end do
      end do
      do i = n - remainder + 1, n, 1
        output(i) = ran0(state) ! function reference
      end do

      new_state  = state

    end subroutine ran0v

    subroutine ran0v2(state, new_state, output, n, m)
      ! wrapper for python

      integer(dp) state(1), new_state(1) ! seed size
      real(dp) output(n, m)

      !f2py intent(in) :: state, n, m
      !f2py intent(out) :: new_state, output

      integer(sp) :: n, m, remainder, remainder2
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      remainder2 = iand(m, unroll_minus_one)

      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1

          do i2 = 1, m - remainder, unroll
            do j2 = 1, unroll, 1
              output(i+j-1, i2+j2-1) = ran0(state) ! function reference
            end do
          end do

          do i2 = m - remainder + 1, m, 1
            output(i+j-1, i2) = ran0(state) ! function reference
          end do

        end do
      end do

      do i = n - remainder + 1, n, 1

        do i2 = 1, m - remainder, unroll
          do j2 = 1, unroll, 1
            output(i, i2+j2-1) = ran0(state) ! function reference
          end do
        end do

        do i2 = m - remainder + 1, m, 1
          output(i, i2) = ran0(state) ! function reference
        end do

      end do

      new_state  = state

    end subroutine ran0v2

    ! ##########################################################################
    ! ##########################################################################

    function ran1(state) result(o)
      ! Numerical Recipes in Fortran77 Ch7.1 <ran1>
      ! Numerical Recipes in C 2Ed Ch7.1 <ran1>

      use types

      integer(dp) state(34)
      integer(dp) idum, ia, im, iq, ir, ntab, ndiv
      real(dp) o, am, eps, rnmx

      parameter (ia = 16807_dp, im = 2147483647_dp, am = 1.0_dp / im, &
        iq = 127773_dp, ir = 2836_dp, ntab = 32, &
        ndiv = 1.0_dp + (im - 1.0_dp) / ntab, eps =1.2e-7, rnmx = 1.0_dp - eps)

      integer(dp) j, k, iv(ntab), iy

      idum = state(1)
      iv = state(2:size(state)-1)
      iy = state(size(state))

      if (idum.le.0_dp.or.iy.eq.0_dp) then
        idum = max(-idum, 1)

        ! if (-idum < 1_dp) then
        !   idum = 1_dp
        ! else
        !   idum = -idum
        ! end if

        do 11 j = ntab+8, 1, -1
          k = idum / iq
          idum = ia * (idum - k * iq) - ir * k
          if (idum.lt.0_dp) idum = idum + im
          if (j.le.ntab) iv(j) = idum
        11 continue
        iy = iv(1)
      endif

      k = idum / iq
      idum = ia * (idum - k * iq) - ir * k
      if (idum.lt.0_dp) idum = idum + im
      j = 1.0_dp + iy / ndiv
      iy = iv(j)
      iv(j) = idum
      o = min(am * iy, rnmx)
      !o = real(o, dp)

      state(1) = idum
      state(2:size(state)-1) = iv
      state(size(state)) = iy

      return
    end

    subroutine ran1v(state, new_state, output, n)
      ! wrapper for python

      integer(dp) state(34), new_state(34) ! seed size
      real(dp) output(n)

      !f2py intent(in) :: state, n
      !f2py intent(out) :: new_state, output

      integer(sp) :: n, remainder
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1
          output(i+j-1) = ran1(state) ! function reference
        end do
      end do
      do i = n - remainder + 1, n, 1
        output(i) = ran1(state) ! function reference
      end do

      new_state  = state

    end subroutine ran1v

    subroutine ran1v2(state, new_state, output, n, m)
      ! wrapper for python

      integer(dp) state(34), new_state(34) ! seed size
      real(dp) output(n, m)

      !f2py intent(in) :: state, n, m
      !f2py intent(out) :: new_state, output

      integer(sp) :: n, m, remainder, remainder2
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      remainder2 = iand(m, unroll_minus_one)

      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1

          do i2 = 1, m - remainder, unroll
            do j2 = 1, unroll, 1
              output(i+j-1, i2+j2-1) = ran1(state) ! function reference
            end do
          end do

          do i2 = m - remainder + 1, m, 1
            output(i+j-1, i2) = ran1(state) ! function reference
          end do

        end do
      end do

      do i = n - remainder + 1, n, 1

        do i2 = 1, m - remainder, unroll
          do j2 = 1, unroll, 1
            output(i, i2+j2-1) = ran1(state) ! function reference
          end do
        end do

        do i2 = m - remainder + 1, m, 1
          output(i, i2) = ran1(state) ! function reference
        end do

      end do

      new_state  = state

    end subroutine ran1v2

    ! ##########################################################################
    ! ##########################################################################

    function ran2(state) result(o)
      ! Numerical Recipes in Fortran77 Ch7.1 <ran2>
      ! Numerical Recipes in C 2Ed Ch7.1 <ran2>

      use types

      integer(dp) state(35)
      integer(dp) idum, im1, im2, imm1, ia1, ia2, iq1, iq2, ir1, ir2, ntab, ndiv
      real(dp) am, eps, rnmx,  o

      parameter (im1 = 2147483563, im2 = 2147483399, am = 1. / im1, &
        imm1 = im1 - 1, ia1 = 40014, ia2 = 40692, iq1 = 53668, iq2 = 52774, &
        ir1 = 12211, ir2 = 3791, ntab = 32, ndiv = 1 + imm1 / ntab, &
        eps = 1.2e-7, rnmx = 1. - eps)

      integer idum2, j ,k, iv(ntab), iy

      idum = state(1)
      iv = state(2:size(state)-2)
      iy = state(size(state)-1)
      idum2 = state(size(state))

      if (idum.le.0) then
        idum = max(-idum, 1)

        ! if (-idum < 1.0) then
        !   idum = 1
        ! else
        !   idum = -idum
        ! end if

        idum2 = idum

        do 11 j = ntab + 8, 1, -1
          k = idum / iq1
          idum = ia1 * (idum - k * iq1) - k * ir1
          if (idum.lt.0) idum = idum + im1
          if (j.le.ntab) iv(j) = idum
        11 continue
        iy = iv(1)
      endif

      k = idum / iq1
      idum = ia1 * (idum - k * iq1) - k * ir1
      if (idum.lt.0) idum = idum + im1
      k = idum2 / iq2
      idum2 = ia2 * (idum2 - k * iq2) - k * ir2
      if (idum2.lt.0) idum2 = idum2 + im2
      j = 1 + iy / ndiv
      iy = iv(j) - idum2
      iv(j) = idum
      if(iy.lt.1) iy = iy + imm1
      o = min(am * iy, rnmx)

      state(1) = idum
      state(2:size(state)-2) = iv
      state(size(state)-1) = iy
      state(size(state)) = idum2

      return
    end

    subroutine ran2v(state, new_state, output, n)
      ! wrapper for python

      integer(dp) state(35), new_state(35) ! seed size
      real(dp) output(n)

      !f2py intent(in) :: state, n
      !f2py intent(out) :: new_state, output

      integer(sp) :: n, remainder
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1
          output(i+j-1) = ran2(state) ! function reference
        end do
      end do
      do i = n - remainder + 1, n, 1
        output(i) = ran2(state) ! function reference
      end do

      new_state  = state

    end subroutine ran2v

    subroutine ran2v2(state, new_state, output, n, m)
      ! wrapper for python

      integer(dp) state(35), new_state(35) ! seed size
      real(dp) output(n, m)

      !f2py intent(in) :: state, n, m
      !f2py intent(out) :: new_state, output

      integer(sp) :: n, m, remainder, remainder2
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      remainder2 = iand(m, unroll_minus_one)

      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1

          do i2 = 1, m - remainder, unroll
            do j2 = 1, unroll, 1
              output(i+j-1, i2+j2-1) = ran2(state) ! function reference
            end do
          end do

          do i2 = m - remainder + 1, m, 1
            output(i+j-1, i2) = ran2(state) ! function reference
          end do

        end do
      end do

      do i = n - remainder + 1, n, 1

        do i2 = 1, m - remainder, unroll
          do j2 = 1, unroll, 1
            output(i, i2+j2-1) = ran2(state) ! function reference
          end do
        end do

        do i2 = m - remainder + 1, m, 1
          output(i, i2) = ran2(state) ! function reference
        end do

      end do

      new_state  = state

    end subroutine ran2v2

    ! ##########################################################################
    ! ##########################################################################

end module rng


!------------------------------------------------------------------------------
!P+
! NAME:
!       Average_SRFs
!
! PURPOSE:
!       Program to average SRFs read in from separate netCDF format SRF
!       data files.
!
! CATEGORY:
!       SRF
!
! LANGUAGE:
!       Fortran-95
!
! MODULES:
!       Type_Kinds:         Module containing definitions for kinds
!                           of variable types.
!
!       File_Utility:       Module containing generic file utility
!                           routines
!
!       Message_Handler:    Module to define simple error codes and
!                           handle error conditions
!                           USEs: FILE_UTILITY module
!
!       List_File_Utility:  Module containing routines for reading list
!                           files, i.e. ASCII files that contain lists of
!                           character or integer data, one item per line.
!                           USEs: TYPE_KINDS module
!                                 FILE_UTILITY module
!                                 Message_Handler module
!
!       Integrate:          Module containing integration routines.
!                           USEs: TYPE_KINDS module
!                                 Message_Handler module
!                                 INTERPOLATE module
!
!       SRF_Define:         Module defining the SRF data structure
!                           and containing routines to manipulate it.
!                           USEs: TYPE_KINDS module
!                                 Message_Handler module
!
!       SRF_netCDF_IO:      Module containing routines to read and
!                           write SRF netCDF format files.
!                           USEs: TYPE_KINDS module
!                                 Message_Handler module
!                                 SRF_DEFINE module
!                                 NETCDF module
!                                 NETCDF_UTILITY module
!
!       SRF_Utility:        Module containing routines for application of
!                           SRF data.
!                           USEs: TYPE_KINDS module
!                                 Message_Handler module
!                                 COMPARE_FLOAT_NUMBERS module
!                                 INTERPOLATE module
!                                 INTEGRATE module
!                                 SRF_DEFINE module
!
! CONTAINS:
!       Compute_Delta_Frequency:  Function to compute the SRF frequency interval
!                                 given the begin and end frequencies and the
!                                 total number of SRF points.
!
! INCLUDE FILES:
!       None.
!
! EXTERNALS:
!       None.
!
! COMMON BLOCKS:
!       None.
!
! FILES ACCESSED:
!       Input and output netCDF SRF data files
!
! SIDE EFFECTS:
!       None.
!
! RESTRICTIONS:
!       None.
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 20-Nov-2002
!                       paul.vandelst@ssec.wisc.edu
!
!  Copyright (C) 2002 Paul van Delst
!
!P-
!------------------------------------------------------------------------------

PROGRAM Average_SRFs

  ! ------------
  ! Module usage
  ! ------------

  USE Type_Kinds
  USE File_Utility
  USE Message_Handler
  USE List_File_Utility

  USE Integrate

  USE SRF_Define
  USE SRF_netCDF_IO
  USE SRF_Utility

  ! -----------------------
  ! Disable implicit typing
  ! -----------------------

  IMPLICIT NONE

  ! ----------
  ! Parameters
  ! ----------

  CHARACTER( * ),  PARAMETER :: PROGRAM_NAME = 'Average_SRFs'
  CHARACTER( * ),  PARAMETER :: PROGRAM_RCS_ID = &
  CHARACTER( * ),  PARAMETER :: PROGRAM_HEADER = &
  '**********************************************************'

  REAL( fp_kind ), PARAMETER :: ZERO = 0.0_fp_kind
  REAL( fp_kind ), PARAMETER :: ONE = 1.0_fp_kind
  REAL( fp_kind ), PARAMETER :: ONEpointFIVE = 1.5_fp_kind

  INTEGER, PARAMETER :: INTERPOLATION_ORDER = 3

  ! ---------
  ! Variables
  ! ---------

  CHARACTER( 256 ) :: message

  INTEGER         :: pn_pos
  CHARACTER( 80 ) :: pn_fmt

  CHARACTER( 256 ) :: List_Filename
  CHARACTER( 256 ) :: Output_SRF_Filename

  TYPE( Character_List_File_type ) :: Input_SRF_Filename_List
  CHARACTER( 256 ) :: Input_SRF_Filename

  INTEGER :: Error_Status
  INTEGER :: Allocate_Status

  INTEGER :: n, n_Files
  INTEGER :: l, n_Channels, n_Channels_Save
  INTEGER :: n_SRF_Points

  CHARACTER( 5000 ) :: History
  CHARACTER(  256 ) :: Sensor_Name
  CHARACTER(  256 ) :: Platform_Name
  CHARACTER( 5000 ) :: Comment

  INTEGER,          DIMENSION( : ), ALLOCATABLE :: Channel_List,    Channel_List_Save
  INTEGER,          DIMENSION( : ), ALLOCATABLE :: n_Points
  REAL( fp_kind ),  DIMENSION( : ), ALLOCATABLE :: Begin_Frequency, Begin_Frequency_Save
  REAL( fp_kind ),  DIMENSION( : ), ALLOCATABLE :: End_Frequency,   End_Frequency_Save
  INTEGER :: NCEP_Sensor_ID,   NCEP_Sensor_ID_Save
  INTEGER :: WMO_Satellite_ID, WMO_Satellite_ID_Save
  INTEGER :: WMO_Sensor_ID,    WMO_Sensor_ID_Save

  REAL( fp_kind ),  DIMENSION( : ), ALLOCATABLE :: Min_Begin_Frequency
  REAL( fp_kind ),  DIMENSION( : ), ALLOCATABLE :: Max_End_Frequency
  REAL( fp_kind ),  DIMENSION( : ), ALLOCATABLE :: Max_Delta_Frequency

  REAL( fp_kind ) :: Averaging_Factor

  TYPE( SRF_type ) :: Input_SRF
  TYPE( SRF_type ) :: iSRF
  TYPE( SRF_type ) :: Output_SRF

  !#----------------------------------------------------------------------------#
  !#                       -- OUTPUT DESCRIPTIVE HEADER --                      #
  !#----------------------------------------------------------------------------#

  pn_pos = ( LEN( PROGRAM_HEADER ) / 2 ) - &
           ( LEN( PROGRAM_NAME ) / 2 )
  pn_pos = MAX( pn_pos, 0 ) + 5
  WRITE( pn_fmt, '( "( ",i2,"x, a )" )' ) pn_pos

  WRITE( *, '(/5x, a)' ) PROGRAM_HEADER
  WRITE( *, FMT = TRIM( pn_fmt ) ) PROGRAM_NAME
  WRITE( *, '(/5x, " Program to average SRFs read in from separate netCDF   ")' )
  WRITE( *, '( 5x, "   format SRF data files.                               ")' )
  WRITE( *, '(/5x, " $Revision: 2.4 $")' )
  WRITE( *, '( 5x, a)' ) PROGRAM_HEADER

  !#----------------------------------------------------------------------------#
  !#                          -- GET USER INPUTS --                             #
  !#----------------------------------------------------------------------------#

  ! ------------------------
  ! The input list file name
  ! ------------------------

  WRITE( *, FMT     = '( /5x, "Enter the input SRF list filename : " )', &
            ADVANCE = 'NO' )
  READ( *, FMT = '( a )' ) List_Filename
  List_Filename = ADJUSTL( List_Filename )

  ! -----------------------
  ! The output SRF filename
  ! -----------------------

  WRITE( *, FMT     = '( /5x, "Enter the output SRF netCDF filename : " )', &
            ADVANCE = 'NO' )
  READ( *, FMT = '( a )' ) Output_SRF_Filename
  Output_SRF_Filename = ADJUSTL( Output_SRF_Filename )

  !#----------------------------------------------------------------------------#
  !#       -- READ THE LIST FILE CONTAINING THE FILENAMES TO AVERAGE --         #
  !#----------------------------------------------------------------------------#

  Error_Status = Read_List_File( List_Filename, &
                                 Input_SRF_Filename_List )

  IF ( Error_Status /= SUCCESS ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Error reading list file '//TRIM( List_Filename ), &
                          Error_Status )
    STOP
  END IF

  ! ----------------------------
  ! Retrieve the number of files
  ! ----------------------------

  n_Files = Get_List_Size( Input_SRF_Filename_List )

  IF ( n_Files < 2 ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Less than 2 files in list file. No averaging to do.', &
                          Error_Status )
    STOP
  END IF

  !#----------------------------------------------------------------------------#
  !#              -- LOOP OVER THE INPUT FILE CHECK THEY "MATCH" --             #
  !#----------------------------------------------------------------------------#

  Input_File_Check_Loop: DO n = 1, n_Files

    ! ------------------------
    ! Get the current filename
    ! ------------------------

    Error_Status = Get_List_Entry( Input_SRF_Filename_List, n, &
                                   Input_SRF_Filename )

    IF ( Error_Status /= SUCCESS ) THEN
      CALL Display_Message( PROGRAM_NAME, &
                            'Error retrieving filename from list for file checking.', &
                            FAILURE )
      STOP
    END IF

    ! ---------------------------
    ! Read the number of channels
    ! ---------------------------

    Error_Status = Inquire_SRF_netCDF( TRIM( Input_SRF_Filename ), &
                                       n_Channels = n_Channels )

    IF ( Error_Status /= SUCCESS ) THEN
      CALL Display_Message( PROGRAM_NAME, &
                            'Error reading n_Channels dimension from the netCDF SRF file '//&
                            TRIM( Input_SRF_Filename ), &
                            Error_Status )
      STOP
    END IF

    ! ----------------------------------------------------
    ! Save the number of channels, channel list, frequency
    ! limits and IDs for checking subsequent files values
    ! ----------------------------------------------------

    First_File_Check: IF ( n == 1 ) THEN

      ! -- Save the number of channels
      n_Channels_Save = n_Channels

      ! -- Allocate the list data and frequency limit arrays
      ALLOCATE( Channel_List( n_Channels ), &
                n_Points( n_Channels ), &
                Begin_Frequency( n_Channels ), &
                End_Frequency( n_Channels ), &
                Channel_List_Save( n_Channels ), &
                Begin_Frequency_Save( n_Channels ), &
                End_Frequency_Save( n_Channels ), &
                Min_Begin_Frequency( n_Channels ), &
                Max_End_Frequency( n_Channels ), &
                Max_Delta_Frequency( n_Channels ), &
                STAT = Allocate_Status )

      IF ( Allocate_Status /= 0 ) THEN
        CALL Display_Message( PROGRAM_NAME, &
                              'Error allocating SRF data arrays.', &
                              FAILURE )
        STOP
      END IF

      ! -- Inquire the current file for the list data
      Error_Status = Inquire_SRF_netCDF( TRIM( Input_SRF_Filename ), &
                                         Channel_List     = Channel_List_Save, &
                                         n_Points         = n_Points, &
                                         Begin_Frequency  = Begin_Frequency_Save, &
                                         End_Frequency    = End_Frequency_Save, &
                                         NCEP_Sensor_ID   = NCEP_Sensor_ID_Save, &
                                         WMO_Satellite_ID = WMO_Satellite_ID_Save, &
                                         WMO_Sensor_ID    = WMO_Sensor_ID_Save, &
                                         History          = History, &
                                         Sensor_Name      = Sensor_Name, &
                                         Platform_Name    = Platform_Name )

      IF ( Error_Status /= SUCCESS ) THEN
        CALL Display_Message( PROGRAM_NAME, &
                              'Error reading channel, frequency, and Sensor ID data '//&
                              'from netCDF SRF file '//&
                              TRIM( Input_SRF_Filename ), &
                              Error_Status )
        STOP
      END IF

      ! -- Initialise some of the arrays
      Min_Begin_Frequency = Begin_Frequency_Save
      Max_End_Frequency   = End_Frequency_Save
      Max_Delta_Frequency = Compute_Delta_Frequency( Min_Begin_Frequency, &
                                                     Max_End_Frequency, &
                                                     n_Points )

    ELSE First_File_Check

      ! ----------------------------
      ! Check the number of channels
      ! ----------------------------

      IF ( n_Channels /= n_Channels_Save ) THEN
        WRITE( Message, '( "Number of channels in file ", a, " (",i4, &
                          &") is different from that expected (",i4,")." )' ) &
                        TRIM( Input_SRF_Filename ), n_Channels, n_Channels_Save
        CALL Display_Message( PROGRAM_NAME, &
                              TRIM( Message ), &
                              FAILURE )
        STOP
      END IF

      ! ---------------------------
      ! Get the current set of data
      ! ---------------------------

      Error_Status = Inquire_SRF_netCDF( TRIM( Input_SRF_Filename ), &
                                         Channel_List     = Channel_List,    &
                                         n_Points         = n_Points, &
                                         Begin_Frequency  = Begin_Frequency, &
                                         End_Frequency    = End_Frequency, &
                                         NCEP_Sensor_ID   = NCEP_Sensor_ID, &
                                         WMO_Satellite_ID = WMO_Satellite_ID, &
                                         WMO_Sensor_ID    = WMO_Sensor_ID )

      IF ( Error_Status /= SUCCESS ) THEN
        CALL Display_Message( PROGRAM_NAME, &
                              'Error reading channel, frequency, and Sensor ID data '//&
                              'from netCDF SRF file '//&
                              TRIM( Input_SRF_Filename ), &
                              Error_Status )
        STOP
      END IF

      ! -----------------------------------------------------------------------
      ! Compare the channel list data. The comparison is not too sophisticated,
      ! it assumes the ORDER of the data is the same as well as the value.
      ! This is not strictly necessary, but to allow different channel
      ! ordering would make this comparison too much of a PITA. :o)
      ! -----------------------------------------------------------------------

      IF ( ANY( ( Channel_List - Channel_List_Save ) /= 0 ) ) THEN
        CALL Display_Message( PROGRAM_NAME, &
                              'Channel_List from netCDF SRF file'//&
                              TRIM( Input_SRF_Filename )//&
                              ' is different.', &
                              FAILURE )
        STOP
      END IF

      ! ---------------------------------------------------------------
      ! Determine the frequency limits. Note that the frequency limits
      ! determined here may sit outside the limits of some of the SRFs
      ! to be averaged. For those SRFs, the "outside" points are set to
      ! zero. This is done to avoid cutting off potentially significant
      ! parts of an SRF.
      ! ---------------------------------------------------------------

      Min_Begin_Frequency = MIN( Min_Begin_Frequency, Begin_Frequency )
      Max_End_Frequency   = MAX( Max_End_Frequency, End_Frequency )
      Max_Delta_Frequency = MAX( Max_Delta_Frequency, &
                                 Compute_Delta_Frequency( Begin_Frequency, &
                                                          End_Frequency,   &
                                                          n_Points         ) )

      ! -------------------
      ! Compare the ID data
      ! -------------------

      ! -- The NCEP Sensor ID
      IF ( NCEP_Sensor_ID /= NCEP_Sensor_ID_Save ) THEN
        CALL Display_Message( PROGRAM_NAME, &
                              'NCEP_Sensor_ID from netCDF SRF file'//&
                              TRIM( Input_SRF_Filename )//&
                              ' is different.', &
                              FAILURE )
        STOP
      END IF

      ! -- The WMO Satellite ID
      IF ( WMO_Satellite_ID /= WMO_Satellite_ID_Save ) THEN
        CALL Display_Message( PROGRAM_NAME, &
                              'WMO_Satellite_ID from netCDF SRF file'//&
                              TRIM( Input_SRF_Filename )//&
                              ' is different.', &
                              FAILURE )
        STOP
      END IF

      ! -- The WMO Sensor ID
      IF ( WMO_Sensor_ID /= WMO_Sensor_ID_Save ) THEN
        CALL Display_Message( PROGRAM_NAME, &
                              'WMO_Sensor_ID from netCDF SRF file'//&
                              TRIM( Input_SRF_Filename )//&
                              ' is different.', &
                              FAILURE )
        STOP
      END IF

    END IF First_File_Check

  END DO Input_File_Check_Loop

  ! ---------------------------------------------------
  ! Compute the averaging weight factor. I do this so
  ! when I average I can multiply across an array
  ! (faster?) rather than do a division across an array
  ! ---------------------------------------------------

  Averaging_Factor = ONE / REAL( n_Files, fp_kind )

  !#----------------------------------------------------------------------------#
  !#                -- DEALLOCATE SOME OF THE LIST DATA FILES --                #
  !#----------------------------------------------------------------------------#

  DEALLOCATE( Begin_Frequency, &
              End_Frequency, &
              Channel_List_Save, &
              Begin_Frequency_Save, &
              End_Frequency_Save, &
              STAT = Allocate_Status )

  IF ( Allocate_Status /= 0 ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Error deallocating no-longer-needed list arrays.', &
                          FAILURE )
    STOP
  END IF

  !#----------------------------------------------------------------------------#
  !#                 -- CREATE THE OUTPUT NETCDF SRF FILE --                    #
  !#----------------------------------------------------------------------------#

  Comment = 'Interpolation to common frequency grid performed. Min and Max frequencies '//&
            'of all detectors used as interpolation endpoints.'

  Error_Status = Create_SRF_netCDF( TRIM( Output_SRF_Filename ), &
                                    Channel_List, &
                                    NCEP_Sensor_ID   = NCEP_Sensor_ID, &
                                    WMO_Satellite_ID = WMO_Satellite_ID, &
                                    WMO_Sensor_ID    = WMO_Sensor_ID, &
                                    Title         = 'Detector-averaged SRFs for '//&
                                                    TRIM( Platform_Name )//' '//&
                                                    TRIM( Sensor_Name ), &
                                    History       = PROGRAM_RCS_ID//'; '//TRIM( History ), &
                                    Sensor_name   = TRIM( Sensor_Name ), &
                                    Platform_name = TRIM( Platform_Name ), &
                                    Comment       = TRIM( Comment ) )

  IF ( Error_Status /= SUCCESS ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Error creating '//TRIM( Output_SRF_Filename ), &
                          Error_Status )
    STOP
  END IF

  !#----------------------------------------------------------------------------#
  !#                -- BEGIN THE AVERAGING LOOP OVER CHANNELS --                #
  !#----------------------------------------------------------------------------#

  Channel_Average_Loop: DO l = 1, n_Channels

    WRITE( *, '( /5x, "Averaging ", a, " ", a, " channel # ", i4 )' ) &
              TRIM( Platform_Name ), TRIM( Sensor_Name ), Channel_List( l )

    ! ----------------------------------------------------------------
    ! Determine the number of SRF points and confirm the end frequency
    ! ----------------------------------------------------------------

    n_SRF_Points = INT( ONEpointFIVE + ( ( Max_End_Frequency(l) - Min_Begin_Frequency(l) ) / &
    !                                    -------------------------------------------------
                                                       Max_Delta_Frequency(l)              ) )

    Max_End_Frequency(l) = Min_Begin_Frequency(l) + &
                           ( REAL( n_SRF_Points - 1, fp_kind ) * Max_Delta_Frequency(l) )

    WRITE( *, '( 10x, "Channel AVE f1, f2, df, and n: ", 2(f12.6), 2x, f11.9, 1x, i5 )' ) &
              Min_Begin_Frequency(l), Max_End_Frequency(l), Max_Delta_Frequency(l), n_SRF_Points

    ! ---------------------------------
    ! Allocate the output SRF Structure
    ! ---------------------------------

    Error_Status = Allocate_SRF( n_SRF_Points, &
                                 Output_SRF )

    IF ( Error_Status /= SUCCESS ) THEN
      WRITE( Message, '( "Error allocating output SRF structure for channel ", i4, "." )' ) &
                      Channel_List( l )
      CALL Display_Message( PROGRAM_NAME, &
                            TRIM( Message ), &
                            Error_Status )
      STOP
    END IF

    ! -- Copy over the available scalar data
    Output_SRF%Sensor_Name   = TRIM( Sensor_Name )
    Output_SRF%Platform_Name = TRIM( Platform_Name )

    Output_SRF%NCEP_Sensor_Id   = NCEP_Sensor_Id
    Output_SRF%WMO_Satellite_Id = WMO_Satellite_Id
    Output_SRF%WMO_Sensor_Id    = WMO_Sensor_Id
    Output_SRF%Channel          = Channel_List( l )

    Output_SRF%Begin_Frequency = Min_Begin_Frequency(l)
    Output_SRF%End_Frequency   = Max_End_Frequency(l)

    ! -- Compute the output frequency grid
    Error_Status = Frequency_SRF( Output_SRF )

    IF ( Error_Status /= SUCCESS ) THEN
      WRITE( Message, '( "Error computing frequency grid for channel ", i4, " output SRF." )' ) &
                      Channel_List( l )
      CALL Display_Message( PROGRAM_NAME, &
                            TRIM( Message ), &
                            Error_Status )
      STOP
    END IF

    ! -- Initialise the SRF response array
    Output_SRF%Response = ZERO

    ! -------------------
    ! Begin the file loop
    ! -------------------

    File_Average_Loop: DO n = 1, n_Files

      ! ------------------------
      ! Get the current filename
      ! ------------------------

      Error_Status = Get_List_Entry( Input_SRF_Filename_List, n, &
                                     Input_SRF_Filename )

      IF ( Error_Status /= SUCCESS ) THEN
        CALL Display_Message( PROGRAM_NAME, &
                              'Error retrieving filename from list for file averaging.', &
                              FAILURE )
        STOP
      END IF

      ! ---------------------------------------------
      ! Read the SRF for the current file and channel
      ! ---------------------------------------------

      Error_Status = Read_SRF_netCDF( TRIM( Input_SRF_Filename ), &
                                      Channel_List( l ), &
                                      Input_SRF )

      IF ( Error_Status /= SUCCESS ) THEN
        WRITE( Message, '( "Error reading channel ", i4, " SRF from ", a, "." )' ) &
                        Channel_List( l ), TRIM( Input_SRF_Filename )
        CALL Display_Message( PROGRAM_NAME, &
                              TRIM( Message ), &
                              Error_Status )
        STOP
      END IF

      WRITE( *, '( 10x, "File #", i5, " f1, f2, df, and n: ", 2(f12.6), 2x, f11.9, 1x, i5 )' ) &
                n, &
                Input_SRF%Begin_Frequency, Input_SRF%End_Frequency, &
                Compute_Delta_Frequency( Input_SRF%Begin_Frequency, Input_SRF%End_Frequency, &
                                         Input_SRF%n_Points ), &
                Input_SRF%n_Points

      ! ------------------------------------------------------
      ! Interpolate the input SRF to the output frequency grid
      ! ------------------------------------------------------

      Error_Status = Interpolate_SRF( Output_SRF%Frequency, &
                                      Input_SRF, &
                                      iSRF, &
                                      Order = INTERPOLATION_ORDER )

      IF ( Error_Status /= SUCCESS ) THEN
        WRITE( Message, '( "Error interpolating input SRF for channel ", i4, "." )' ) &
                        Channel_List( l )
        CALL Display_Message( PROGRAM_NAME, &
                              TRIM( Message ), &
                              Error_Status )
        STOP
      END IF

      ! ---------------------------
      ! Accumulate the SRF response
      ! ---------------------------

      Output_SRF%Response = Output_SRF%Response + iSRF%Response

      ! ------------------------------------------------
      ! Destroy the input and interpolated SRF structure
      ! ------------------------------------------------

      Error_Status = Destroy_SRF( Input_SRF )

      IF ( Error_Status /= SUCCESS ) THEN
        WRITE( Message, '( "Error destroying input SRF structure for channel ", i4, " from ", a, "." )' ) &
                        Channel_List( l ), TRIM( Input_SRF_Filename )
        CALL Display_Message( PROGRAM_NAME, &
                              TRIM( Message ), &
                              Error_Status )
        STOP
      END IF

      Error_Status = Destroy_SRF( iSRF )

      IF ( Error_Status /= SUCCESS ) THEN
        WRITE( Message, '( "Error destroying inteprolated SRF structure for channel ", i4, " from ", a, "." )' ) &
                        Channel_List( l ), TRIM( Input_SRF_Filename )
        CALL Display_Message( PROGRAM_NAME, &
                              TRIM( Message ), &
                              Error_Status )
        STOP
      END IF

    END DO File_Average_Loop

    ! ---------------------------------------------
    ! Average and normalise the output SRF response
    ! ---------------------------------------------

    Output_SRF%Response = Averaging_Factor * Output_SRF%Response
    Output_SRF%Response = Output_SRF%Response / MAXVAL( Output_SRF%Response )

    ! ----------------------------------
    ! Integrate the average SRF response
    ! ----------------------------------

    Error_Status = Integrate_SRF( Output_SRF )

    IF ( Error_Status /= SUCCESS ) THEN
      WRITE( Message, '( "Error occurred integrating channel #", i4, " average SRF." )' ) &
                      Output_SRF%Channel
      CALL Display_Message( PROGRAM_NAME, &
                            TRIM( Message ), &
                            Error_Status )
      STOP
    END IF

    ! ------------------------------
    ! Write the averaged SRF to file
    ! ------------------------------

    Error_Status = Write_SRF_netCDF( TRIM( Output_SRF_Filename ), &
                                     Output_SRF )

    IF ( Error_Status /= SUCCESS ) THEN
      WRITE( Message, '( "Error writing channel ", i4, " average SRF to ", a, "." )' ) &
                      Channel_List( l ), TRIM( Output_SRF_Filename )
      CALL Display_Message( PROGRAM_NAME, &
                            TRIM( Message ), &
                            Error_Status )
      STOP
    END IF

    ! -----------------------------------------------------
    ! Destroy the output SRF structure for the next channel
    ! -----------------------------------------------------

    Error_Status = Destroy_SRF( Output_SRF )

    IF ( Error_Status /= SUCCESS ) THEN
      WRITE( Message, '( "Error destroying output SRF structure for channel ", i4, "." )' ) &
                      Channel_List( l )
      CALL Display_Message( PROGRAM_NAME, &
                            TRIM( Message ), &
                            Error_Status )
      STOP
    END IF

  END DO Channel_Average_Loop

  !#----------------------------------------------------------------------------#
  !#                    -- DEALLOCATE CHANNEL LIST ARRAY --                     #
  !#----------------------------------------------------------------------------#

  DEALLOCATE( Channel_List, &
              n_Points, &
              Min_Begin_Frequency, &
              Max_End_Frequency, &
              Max_Delta_Frequency, &
              STAT = Allocate_Status )

  IF ( Allocate_Status /= 0 ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Error deallocating data arrays.', &
                          WARNING )
  END IF

CONTAINS

  ELEMENTAL FUNCTION Compute_Delta_Frequency( f1, f2, n ) RESULT ( df )
    REAL( fp_kind ), INTENT( IN ) :: f1, f2
    INTEGER,         INTENT( IN ) :: n
    REAL( fp_kind ) :: df

    df = ( f2 - f1 ) / REAL( n-1, fp_kind )

  END FUNCTION Compute_Delta_Frequency

END PROGRAM Average_SRFs