!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2021 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 envtemp(itg,ieg,ntg,ntr,sideload,nelemload,
     &     ipkon,kon,lakon,ielmat,ne,nload,kontri,ntri,nloadtr,
     &     nflow,ndirboun,nactdog,nodeboun,nacteq,nboun,
     &     ielprop,prop,nteq,v,network,physcon,shcon,ntmat_,
     &     co,vold,set,nshcon,rhcon,nrhcon,mi,
     &     nmpc,nodempc,ipompc,labmpc,ikboun,nasym,ttime,time,iaxial)
!
!     determines the number of gas temperatures and radiation
!     temperatures
!
      implicit none
!
      logical identity,walltemp,temperaturebc,pressurebc,massflowbcall,
     &     pressurebcall
!
      character*8 lakon(*)
      character*20 labmpc(*)
      character*20 sideload(*)
      character*81 set(*)
!
      integer itg(*),ntg,ntr,nelemload(2,*),ipkon(*),network,mi(*),
     &     kon(*),ielmat(mi(3),*),ne,i,j,k,l,index,id,node,nload,
     &     ifaceq(8,6),ider,nasym,indexe,iaxial,networkmpcs,
     &     ifacet(6,4),ifacew(8,5),kontri3(3,1),kontri4(3,2),
     &     kontri6(3,4),kontri8(3,6),kontri(4,*),ntri,
     &     konf(8),nloadtr(*),nelem,nope,nopes,ig,nflow,ieg(*),
     &     ndirboun(*),nactdog(0:3,*),nboun,nodeboun(*),ntmat_,
     &     idir,ntq,nteq,nacteq(0:3,*),node1,node2,nodem,
     &     ielprop(*),idirf(8),iflag,imat,numf,nrhcon(*),nshcon(*),
     &     nmpc,nodempc(3,*),ipompc(*),ikboun(*),iplausi
!
      real*8 prop(*),f,xflow,nodef(8),df(8),v(0:mi(2),*),g(3),
     &     cp,r,physcon(*),shcon(0:3,ntmat_,*),rho,ttime,time,
     &     co(3,*),dvi,vold(0:mi(2),*),rhcon(*)
!
      data ifaceq /4,3,2,1,11,10,9,12,
     &            5,6,7,8,13,14,15,16,
     &            1,2,6,5,9,18,13,17,
     &            2,3,7,6,10,19,14,18,
     &            3,4,8,7,11,20,15,19,
     &            4,1,5,8,12,17,16,20/
      data ifacet /1,3,2,7,6,5,
     &     1,2,4,5,9,8,
     &     2,3,4,6,10,9,
     &     1,4,3,8,10,7/
      data ifacew /1,3,2,9,8,7,0,0,
     &     4,5,6,10,11,12,0,0,
     &     1,2,5,4,7,14,10,13,
     &     2,3,6,5,8,15,11,14,
     &     4,6,3,1,12,15,9,13/
      data kontri3 /1,2,3/
      data kontri4 /1,2,4,2,3,4/
      data kontri6 /1,4,6,4,5,6,4,2,5,6,5,3/
      data kontri8 /1,5,8,8,5,7,8,7,4,5,2,6,5,6,7,7,6,3/
!
      ntg=0
      ntr=0
      ntri=0
!
      walltemp=.false.
      temperaturebc=.false.
      pressurebc=.false.
      massflowbcall=.true.
      pressurebcall=.true.
!
      networkmpcs=0
!
!     ordering the gas temperature nodes and counting them
!     counting the radiation temperatures
!
      do i=1,nload
         if(sideload(i)(3:4).eq.'FC') then
            walltemp=.true.
            call nident(itg,nelemload(2,i),ntg,id)
            if(id.gt.0) then
               if(itg(id).eq.nelemload(2,i)) then
                  nactdog(0,nelemload(2,i))=1
                  cycle
               endif
            endif
            ntg=ntg+1
            do j=ntg,id+2,-1
               itg(j)=itg(j-1)
            enddo
            itg(id+1)=nelemload(2,i)
            nactdog(0,nelemload(2,i))=1
!
         elseif(sideload(i)(3:4).eq.'NP') then
            call nident(itg,nelemload(2,i),ntg,id)
            if(id.gt.0) then
               if(itg(id).eq.nelemload(2,i)) then
                  nactdog(2,nelemload(2,i))=1
                  cycle
               endif
            endif
            ntg=ntg+1
            do j=ntg,id+2,-1
               itg(j)=itg(j-1)
            enddo
            itg(id+1)=nelemload(2,i)
            nactdog(2,nelemload(2,i))=1
!
         elseif(sideload(i)(3:4).eq.'CR') then
            ntr=ntr+1
            nelem=nelemload(1,i)
            read(sideload(i)(2:2),'(i1)') ig
!
!     number of nodes in the face
!
            if(lakon(nelem)(4:4).eq.'2') then
               nope=20
               nopes=8
            elseif(lakon(nelem)(4:4).eq.'8') then
               nope=8
               nopes=4
            elseif(lakon(nelem)(4:5).eq.'10') then
               nope=10
               nopes=6
            elseif(lakon(nelem)(4:4).eq.'4') then
               nope=4
               nopes=3
            elseif(lakon(nelem)(4:4).eq.'6') then
               nope=6
               if(ig.le.2) then
                  nopes=3
               else
                  nopes=4
               endif
            elseif(lakon(nelem)(4:5).eq.'15') then
               nope=15
               if(ig.le.2) then
                  nopes=6
               else
                  nopes=8
               endif
            endif
!
!     nodes in the face
!
            if((nope.eq.20).or.(nope.eq.8)) then
               do k=1,nopes
                  konf(k)=kon(ipkon(nelem)+ifaceq(k,ig))
               enddo
            elseif((nope.eq.10).or.(nope.eq.4)) then
               do k=1,nopes
                  konf(k)=kon(ipkon(nelem)+ifacet(k,ig))
               enddo
            else
               do k=1,nopes
                  konf(k)=kon(ipkon(nelem)+ifacew(k,ig))
               enddo
            endif
!
!     triangulation of the face
!
            nloadtr(ntr)=i
            if((lakon(nelem)(4:4).eq.'2').or.
     &           ((lakon(nelem)(4:5).eq.'15').and.(ig.gt.2))) then
               do k=1,6
                  ntri=ntri+1
                  do l=1,3
                     kontri(l,ntri)=konf(kontri8(l,k))
                  enddo
                  kontri(4,ntri)=ntr
               enddo
            elseif((lakon(nelem)(4:4).eq.'8').or.
     &              ((lakon(nelem)(4:4).eq.'6').and.(ig.gt.2))) then
               do k=1,2
                  ntri=ntri+1
                  do l=1,3
                     kontri(l,ntri)=konf(kontri4(l,k))
                  enddo
                  kontri(4,ntri)=ntr
               enddo
            elseif((lakon(nelem)(4:5).eq.'10').or.
     &              ((lakon(nelem)(4:5).eq.'15').and.(ig.le.2))) then
               do k=1,4
                  ntri=ntri+1
                  do l=1,3
                     kontri(l,ntri)=konf(kontri6(l,k))
                  enddo
                  kontri(4,ntri)=ntr
               enddo
            elseif((lakon(nelem)(4:4).eq.'4').or.
     &              ((lakon(nelem)(4:4).eq.'6').and.(ig.le.2))) then
               do k=1,1
                  ntri=ntri+1
                  do l=1,3
                     kontri(l,ntri)=konf(kontri3(l,k))
                  enddo
                  kontri(4,ntri)=ntr
               enddo
            endif
         endif
      enddo
!
!     storing the gas elements in a dedicated array
!
      nflow=0
!
      do i=1,ne
         if(lakon(i)(1:1).eq.'D') then
            if((lakon(i)(2:2).ne.' ').and.(network.ne.1)) then
               nflow=nflow+1
               ieg(nflow)=i
            else
               nasym=1
!
!              removing gas nodes belonging to 'D '-elements
!              in which a 'FC'-film condition was applied from the
!              itg vector
!
               indexe=ipkon(i)
               do j=1,3,2
                  node=kon(indexe+j)
                  call nident(itg,node,ntg,id)
                  if(id.gt.0) then
                     if(itg(id).eq.node) then
                        ntg=ntg-1
                        do k=id,ntg
                           itg(k)=itg(k+1)
                        enddo
                        nactdog(0,node)=0
                        nactdog(2,node)=0
                     endif
                  endif
               enddo
!
            endif
         endif
!
!        removing gas nodes belonging to advective elements
!        (last node in the element topology)
!        these are usually gas nodes not belonging to any
!        "D"-element
!
         if(lakon(i)(1:7).eq.'ESPRNGF') then
            read(lakon(i)(8:8),'(i1)') nopes
            nope=nopes+1
            node=kon(ipkon(i)+nope)
!
            call nident(itg,node,ntg,id)
            if(id.gt.0) then
               if(itg(id).eq.node) then
                  ntg=ntg-1
                  do k=id,ntg
                     itg(k)=itg(k+1)
                  enddo
                  nactdog(0,node)=0
                  nactdog(2,node)=0
               endif
            endif
         endif
      enddo
!
!     mass flux nodes are also taken as unknowns in the
!     gas temperature system; determining the active
!     degrees of freedom
!
!     first node of the flow element
!
      do i=1,nflow
         index=ipkon(ieg(i))
         node=kon(index+1)
         if (node.eq.0) cycle
         call nident(itg,node,ntg,id)
         if(id.gt.0) then
            if(itg(id).eq.node) then
!
!              upstream depth of SO,WO and DO is known
!
               if((lakon(ieg(i))(4:7).eq.'CHSO').or.
     &              (lakon(ieg(i))(4:7).eq.'CHWO').or.
     &              (lakon(ieg(i))(4:7).eq.'CHDO')) cycle
               nactdog(0,node)=1
               nactdog(2,node)=1
               cycle
           endif
         endif
         ntg=ntg+1
         do j=ntg,id+2,-1
            itg(j)=itg(j-1)
         enddo
         itg(id+1)=node
!
!        upstream depth of SO,WO and DO is known
!
         if((lakon(ieg(i))(4:7).eq.'CHSO').or.
     &      (lakon(ieg(i))(4:7).eq.'CHWO').or.
     &      (lakon(ieg(i))(4:7).eq.'CHDO')) cycle
         nactdog(0,node)=1
         nactdog(2,node)=1
      enddo
!
!     middle node of the flow element :flux
!
      do i=1,nflow
         index=ipkon(ieg(i))
         node=kon(index+2)
         call nident(itg,node,ntg,id)
         if(id.gt.0) then
            if(itg(id).eq.node) cycle
         endif
         ntg=ntg+1
         do j=ntg,id+2,-1
            itg(j)=itg(j-1)
        enddo
        itg(id+1)=node
        nactdog(1,node)=1
!
!        variable geometric property
!
        if(lakon(ieg(i))(6:7).eq.'GV') then
           index=ielprop(ieg(i))
           if(prop(index+2).le.0.d0) nactdog(3,node)=1
        elseif((lakon(ieg(i))(4:7).eq.'CHSG').or.
     &         (lakon(ieg(i))(4:7).eq.'CHWE').or.
     &         (lakon(ieg(i))(4:7).eq.'CHDS')) then
           nactdog(3,node)=1
        elseif(lakon(ieg(i))(2:7).eq.'ACCTUB') then
!
            index=ielprop(ieg(i))
            if(prop(index+1).eq.2) then
!              Interval factor unknown,setting a DOF for geometry
               nactdog(3,node)=1
            elseif(prop(index+1).eq.3) then
!              Hole diameter factor unknown,setting a DOF for geometry
               nactdog(3,node)=1
            endif
        endif
      enddo
!
!     third node of the flow element
!
      do i=1,nflow
         index=ipkon(ieg(i))
         node=kon(index+3)
         if (node.eq.0) cycle
         call nident(itg,node,ntg,id)
         if(id.gt.0) then
            if(itg(id).eq.node) then
!
!              downstream depth of SG,WE and DS is known
!
               if((lakon(ieg(i))(4:7).eq.'CHSG').or.
     &            (lakon(ieg(i))(4:7).eq.'CHWE').or.
     &            (lakon(ieg(i))(4:7).eq.'CHDS')) cycle
               nactdog(0,node)=1
               nactdog(2,node)=1
               cycle
            endif
         endif
         ntg=ntg+1
         do j=ntg,id+2,-1
            itg(j)=itg(j-1)
         enddo
         itg(id+1)=node
!
!        downstream depth of SG,WE and DS is known
!
         if((lakon(ieg(i))(4:7).eq.'CHSG').or.
     &        (lakon(ieg(i))(4:7).eq.'CHWE').or.
     &        (lakon(ieg(i))(4:7).eq.'CHDS')) cycle
         nactdog(0,node)=1
         nactdog(2,node)=1
      enddo
!
!     tagging the network MPC's
!
      do i=1,nmpc
!
!        check whether network MPC
!
         index=ipompc(i)
         do
            node=nodempc(1,index)
            call nident(itg,node,ntg,id)
            if(id.gt.0) then
               if(itg(id).eq.node) then
                  labmpc(i)(1:7)='NETWORK'
                  networkmpcs=1
                  exit
               endif
            endif
            index=nodempc(3,index)
            if(index.eq.0) exit
         enddo
      enddo
!
!     taking the MPC network nodes into account
!
      if(networkmpcs.eq.1) then
         do i=1,nmpc
            if(labmpc(i)(1:7).ne.'NETWORK') cycle
!
            index=ipompc(i)
            do
               node=nodempc(1,index)
               call nident(itg,node,ntg,id)
               if(id.gt.0) then
                  if(itg(id).eq.node) then
                     nactdog(nodempc(2,index),node)=1
                     index=nodempc(3,index)
                     if(index.eq.0) then
                        exit
                     else
                        cycle
                     endif
                  endif
               endif
!
!              adding a node to itg
!
               ntg=ntg+1
               do j=ntg,id+2,-1
                  itg(j)=itg(j-1)
               enddo
               itg(id+1)=node
               nactdog(nodempc(2,index),node)=1
               index=nodempc(3,index)
               if(index.eq.0) exit
            enddo
         enddo
      endif
!
!     subtracting the SPC conditions
!
      do i=1,nboun
         node=nodeboun(i)
         call nident(itg,node,ntg,id)
         if (id.gt.0) then
            if (itg(id).eq.node) then
               idir=ndirboun(i)
               nactdog(idir,node)=0
               if(idir.eq.0) then
                  temperaturebc=.true.
               elseif(idir.eq.2) then
                  pressurebc=.true.
               endif
            endif
         endif
      enddo
!
!     temporarily removing the dependent nodes of the MPC's
!     only for mass flow and pressure
!
!     these are the only dofs for which the corresponding equations
!     (mass equilibrium in end node and element equation in middle
!     node) are not applied in the nodes where the dofs are lacking
!     (mass flow in middle node and pressure in end node)
!
      if(networkmpcs.eq.1) then
         do i=1,nmpc
            if(labmpc(i)(1:7).ne.'NETWORK') cycle
            index=ipompc(i)
            idir=nodempc(2,index)
            if((idir.eq.1).or.(idir.eq.2)) then
               node=nodempc(1,index)
               call nident(itg,node,ntg,id)
               if(id.gt.0) then
                  if(itg(id).eq.node) then
                     nactdog(idir,node)=0
                  endif
               endif
            endif
         enddo
      endif
!
!     determining the active equations
!
!     element contributions
!
      iflag=0
      do i=1,nflow
         nelem=ieg(i)
         index=ipkon(nelem)
         node1=kon(index+1)
         nodem=kon(index+2)
         node2=kon(index+3)
!
!     "end of network" element ---X---O
!                             1   m   2
!
         if(node1.eq.0)then
            if ((nactdog(1,nodem).ne.0).or.(nactdog(3,nodem).ne.0))then
               nacteq(1,node2)=1                      ! mass equation
            endif
            if (nactdog(0,node2).ne.0)then
               nacteq(0,node2)=1                      ! energy equation
            endif
!
!     "end of network" element node O---X---
!     1   m   2
         elseif (node2.eq.0) then
            if ((nactdog(1,nodem).ne.0).or.(nactdog(3,nodem).ne.0))then
               nacteq(1,node1)=1                      ! mass equation
            endif
            if (nactdog(0,node1).ne.0)then
               nacteq(0,node1)=1                      ! energy equation
            endif
!
!     "flow element" O---X---O
!                    1   m   2
!
         else
            if((nactdog(1,nodem).ne.0).or.(nactdog(3,nodem).ne.0)) then
               nacteq(1,node2)=1                       ! mass equation
               nacteq(1,node1)=1                       ! mass equation
            endif
!
            ider=0
            call flux(node1,node2,nodem,nelem,lakon,kon,ipkon,
     &           nactdog,identity,ielprop,prop,iflag,v,xflow,f,
     &           nodef,idirf,df,cp,r,rho,physcon,g,co,dvi,numf,
     &           vold,set,shcon,nshcon,rhcon,nrhcon,ntmat_,mi,ider,
     &           ttime,time,iaxial,iplausi)
!
            if (.not.identity) then
               nacteq(2,nodem)=1                       ! momentum equation
            endif
!
            if (nactdog(0,node1).ne.0)then
               nacteq(0,node1)=1                       ! energy equation
            endif
!
            if (nactdog(0,node2).ne.0)then
               nacteq(0,node2)=1                       ! energy equation
            endif
         endif
      enddo
!
!     wall convective contributions
!
      do i=1, nload
         if((sideload(i)(3:4)).eq.'FC')then
            node=nelemload(2,i)
            if (nactdog(0,node).ne.0) then
               nacteq(0,node)=1
            endif
         endif
      enddo
!
!     restoring the dependent nodes of the MPC's
!     only for mass flow and pressure
!
      if(networkmpcs.eq.1) then
         do i=1,nmpc
            if(labmpc(i)(1:7).ne.'NETWORK') cycle
            index=ipompc(i)
            idir=nodempc(2,index)
            if((idir.eq.1).or.(idir.eq.2)) then
               node=nodempc(1,index)
               call nident(itg,node,ntg,id)
               if(id.gt.0) then
                  if(itg(id).eq.node) then
                     nactdog(idir,node)=1
                  endif
               endif
            endif
         enddo
      endif
!
!     removing the energy equation from those end nodes for which
!     the temperature constitutes the first term in a network MPC
!
      if(networkmpcs.eq.1) then
         do i=1,nmpc
            if(labmpc(i)(1:7).ne.'NETWORK') cycle
            index=ipompc(i)
            idir=nodempc(2,index)
            if(idir.eq.0) then
               node=nodempc(1,index)
               call nident(itg,node,ntg,id)
               if(id.gt.0) then
                  if(itg(id).eq.node) then
                     nacteq(0,node)=0
                  endif
               endif
            endif
         enddo
      endif
!
!     check whether all mass flow is known
!
      do i=1,ntg
         node=itg(i)
         if((nactdog(1,node).ne.0).or.(nactdog(3,node).ne.0)) then
            massflowbcall=.false.
            exit
         endif
      enddo
!
!     check whether all pressures are known
!
      do i=1,ntg
         node=itg(i)
         if(nactdog(2,node).ne.0) then
            pressurebcall=.false.
            exit
         endif
      enddo
!
!     check for special cases
!
      if(massflowbcall.and.((.not.pressurebc).or.(pressurebcall))) then
!
!        purely thermal (only set to 1 if D-type elements are present)
!
         if(network.gt.1) network=2
         do i=1,nflow
            nelem=ieg(i)
            index=ipkon(nelem)
            node1=kon(index+1)
            nodem=kon(index+2)
            node2=kon(index+3)
            nacteq(2,nodem)=0
            if(node1.ne.0) nactdog(2,node1)=0
            if(node2.ne.0) nactdog(2,node2)=0
         enddo
      elseif((.not.temperaturebc).and.(.not.walltemp)) then
!
!        pure liquid dynamics
!
         write(*,*) '*INFO in envtemp: no thermal boundary conditions'
         write(*,*) '      detected; the network is considered to be'
         write(*,*) '      athermal and no gas temperatures will be'
         write(*,*) '      calculated'
         network=4
         do i=1,ntg
            node=itg(i)
            nactdog(0,node)=0
            nacteq(0,node)=0
         enddo
      elseif((.not.temperaturebc).and.walltemp) then
         write(*,*) '*ERROR in envtemp: at least one temperature'
         write(*,*) '       boundary condition must be given'
         call exit(201)
      elseif(.not.pressurebc) then
         write(*,*) '*ERROR in envtemp: at least one pressure'
         write(*,*) '       boundary condition must be given'
         call exit(201)
      endif
!
!     check whether a specific gas constant was defined for all fluid
!     elements (except for purely thermal calculations)
!
      if(network.gt.2) then
         do i=1,nflow
            nelem=ieg(i)
            if((lakon(nelem)(2:3).eq.'LI').or.
     &         (lakon(nelem)(2:3).eq.'LP').or.
     &         (lakon(nelem)(2:3).eq.'  ')) cycle
            imat=ielmat(1,nelem)
            r=shcon(3,1,imat)
            if(r.lt.1.d-10) then
               write(*,*)'*ERROR in envtemp: specific gas',
     &              'constant is close to zero'
               call exit(201)
            endif
         enddo
      endif
!
!     check whether the temperature at each inlet or outlet node
!     is given
!
      if(network.lt.4) then
         do i=1,nflow
            nelem=ieg(i)
            index=ipkon(nelem)
            node1=kon(index+1)
            node2=kon(index+3)
            if(node1.eq.0) then
               if(nactdog(0,node2).ne.0) then
               write(*,*) '*WARNING in envtemp: it is advised to'
               write(*,*) '         define the temperature at all'
               write(*,*) '         inlets and outlets by a boundary'
               write(*,*) '         condition. This is lacking for'
               write(*,*) '         node ',node2,' of element ',nelem
               endif
            endif
            if(node2.eq.0) then
               if(nactdog(0,node1).ne.0) then
               write(*,*) '*WARNING in envtemp: it is advised to'
               write(*,*) '         define the temperature at all'
               write(*,*) '         inlets and outlets by a boundary'
               write(*,*) '         condition. This is lacking for'
               write(*,*) '         node ',node1,' of element ',nelem
               endif
            endif
         enddo
      endif
!
!     numbering the active equations
!
      nteq=0
      do i=1,ntg
         node=itg(i)
         do j=0,2
            if (nacteq(j,node).ne.0) then
               nteq=nteq+1
               nacteq(j,node)=nteq
            endif
         enddo
!         write(30,*) 'unknowns ',node,(nactdog(j,node),j=0,3)
      enddo
!      do i=1,ntg
!         node=itg(i)
!         write(30,*) 'equations',node,(nacteq(j,node),j=0,2)
!      enddo
!
!     taking network MPC's into account
!
      if(networkmpcs.eq.1) then
         do i=1,nmpc
            if(labmpc(i)(1:7).eq.'NETWORK') nteq=nteq+1
         enddo
      endif
!
!     numbering the active degrees of freedom
!
      ntq=0
      do i=1,ntg
         node=itg(i)
         do  j=0,3
            if (nactdog(j,node).ne.0) then
               ntq=ntq+1
               nactdog(j,node)=ntq
            endif
         enddo
      enddo
c
c      open(30,file='dummy',status='unknown')
c      write(30,*) 'nactdog'
c      do i=1,ntg
c         write(30,*) itg(i),(nactdog(j,itg(i)),j=0,3)
c      enddo
c
c      write(30,*) ''
c      write(30,*) 'nacteq'
c      do i=1,ntg
c         write(30,*) itg(i),(nacteq(j,itg(i)),j=0,3)
c      enddo
c      close(30)
!
      if(ntq.ne.nteq) then
         write(*,*) '*ERROR in envtemp:'
         write(*,*) '*****number of network equations is not equal to'
         write(*,*) ' number of active degrees of freedom*****'
         write(*,*) ' # of network equations = ',nteq
         write(*,*) ' # of active degrees of freedom= ',ntq
         call exit(201)
      endif
!
!     for isothermal gas pipes the energy equation in the
!     topologically downstream node is replaced by an equation
!     expressing the equality of the static temperature at both
!     ends of the pipe. To this end these downstream nodes are
!     referring in nacteq(3,*) to the topologically upstream node
!
!     if the temperature in the downstream node is a boundary
!     condition (i.e. the energy equation is not built), the
!     energy equation in the upstream node is replaced. In that
!     case nacteq(3,upstreamnode) refers to the downstream node.
!
!     if both nodes are boundary conditions, nothing is done
!
      do i=1,nflow
         nelem=ieg(i)
         if((lakon(nelem)(1:4).eq."DGAP")
     &        .and.(lakon(nelem)(6:6).eq."I")) then
!
            index=ipkon(nelem)
            node1=kon(index+1)
            node2=kon(index+3)
            if((node1.eq.0).or.(node2.eq.0)) cycle
!
            if(nacteq(0,node2).ne.0) then
               nacteq(3,node2)=node1
            elseif(nacteq(0,node1).ne.0) then
               nacteq(3,node1)=node2
            endif
         endif
      enddo
!
      return
      end


!**********************************************************************************************************************************
! LICENSING
! Copyright (C) 2020 National Renewable Energy Laboratory
! Copyright (C) 2020 Matthew Hall
!
!    This file is part of MoorDyn.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!
!**********************************************************************************************************************************
PROGRAM MoorDyn_Driver

   USE MoorDyn_Types
   USE MoorDyn
   USE NWTC_Library

   IMPLICIT NONE

    !__________________________________________________________________________�������________________________________________________________________
     !1�Ŵ���1����������ϵ��+ +������
     !2�Ŵ���1����������ϵ��+ -������
     !3�Ŵ���1����������ϵ��- +������
     !4�Ŵ���1����������ϵ��- -������

     !����ʼ�����ɶ�
      REAL  , DIMENSION(1:6)        :: VesselFreedom1_Init!1�Ŵ���ʼ�����ɶ� m m m rad rad rad
      REAL  , DIMENSION(1:6)        :: VesselFreedom2_Init!2�Ŵ���ʼ�����ɶ� m m m rad rad rad
      REAL  , DIMENSION(1:6)        :: VesselFreedom3_Init!3�Ŵ���ʼ�����ɶ� m m m rad rad rad
      REAL  , DIMENSION(1:6)        :: VesselFreedom4_Init!4�Ŵ���ʼ�����ɶ� m m m rad rad rad

      !�������ɶ�
      REAL  , DIMENSION(1:6)        :: VesselFreedom1!1�Ŵ������ɶ� m m m rad rad rad
      REAL  , DIMENSION(1:6)        :: VesselFreedom2!2�Ŵ������ɶ� m m m rad rad rad
      REAL  , DIMENSION(1:6)        :: VesselFreedom3!3�Ŵ������ɶ� m m m rad rad rad
      REAL  , DIMENSION(1:6)        :: VesselFreedom4!4�Ŵ������ɶ� m m m rad rad rad
      !���˶��ٶ�
      REAL  , DIMENSION(1:6)        :: VesselFairleadVe1!һ�����ֵ��¿�ƽ���ٶ� m/s  m/s m/s rad/s rad/s rad/s
      REAL  , DIMENSION(1:6)        :: VesselFairleadVe2!�������ֵ��¿�ƽ���ٶ� m/s  m/s m/s rad/s rad/s rad/s
      REAL  , DIMENSION(1:6)        :: VesselFairleadVe3!�������ֵ��¿�ƽ���ٶ� m/s  m/s m/s rad/s rad/s rad/s
      REAL  , DIMENSION(1:6)        :: VesselFairleadVe4!�ĺ����ֵ��¿�ƽ���ٶ� m/s  m/s m/s rad/s rad/s rad/s

      !�ʳ��ٶ�  >0��ʾ���� <0 ��ʾ����
      REAL                          :: WhichSpeed9       !������9�Žʳ��ٶ�m/min
      REAL                          :: WhichSpeed10       !������10�Žʳ��ٶ�m/min
      !__________________________________________________________________________�������________________________________________________________________
      !��������
      REAL  , DIMENSION(:,:), ALLOCATABLE        :: Line1!1����������
      REAL  , DIMENSION(:,:), ALLOCATABLE        :: Line2!2����������
      REAL  , DIMENSION(:,:), ALLOCATABLE        :: Line3!3����������
      REAL  , DIMENSION(:,:), ALLOCATABLE        :: Line4!3����������
      REAL  , DIMENSION(:,:), ALLOCATABLE        :: Line5!������9����������
      REAL  , DIMENSION(:,:), ALLOCATABLE        :: Line6!������10����������
      !����������(���ظ�����)
      REAL  , DIMENSION(3)          :: Flines1!1�����ֵ��¿�XYZ�������[N]
      REAL  , DIMENSION(3)          :: Flines2!2�����ֵ��¿�XYZ�������[N]
      REAL  , DIMENSION(3)          :: Flines3!3�����ֵ��¿�XYZ�������[N]
      REAL  , DIMENSION(3)          :: Flines4!4�����ֵ��¿�XYZ�������[N]
     !__________________________________________________________________________�������________________________________________________________________

   INTEGER(IntKi)                        :: ErrStat          ! Status of error message
   CHARACTER(1024)                       :: ErrMsg           ! Error message if ErrStat /= ErrID_None

   TYPE (MD_InitInputType)               :: MD_InitInput
   TYPE (MD_ParameterType)               :: MD_Parameter
   TYPE (MD_ContinuousStateType)         :: MD_ContinuousState
   TYPE (MD_InitOutputType)              :: MD_InitOutput
   TYPE (MD_DiscreteStateType)           :: MD_DiscreteState
   TYPE (MD_ConstraintStateType)         :: MD_ConstraintState
   TYPE (MD_OtherStateType)              :: MD_OtherState
   TYPE (MD_MiscVarType)                 :: MD_MiscVar

   TYPE (MD_InputType),      ALLOCATABLE :: MD_Input(:)
   REAL(DbKi), DIMENSION(:), ALLOCATABLE :: MD_InputTimes

   TYPE (MD_OutputType)                  :: MD_Output        ! Output file identifier

   INTEGER(IntKi)                        :: UnPtfmMotIn      ! platform motion input file identifier
   CHARACTER(100)                        :: Line             ! String to temporarially hold value of read line
   REAL(ReKi), ALLOCATABLE               :: PtfmMotIn(:,:)   ! Variable for storing time, and DOF time series from driver input file
   REAL(ReKi), ALLOCATABLE               :: PtfmMot(:,:)     ! Variable for storing interpolated DOF time series from driver input file
   INTEGER(IntKi)                        :: ntIn             ! number of time steps read from driver input file
   INTEGER(IntKi)                        :: ncIn             ! number of channels read from driver input file
   INTEGER(IntKi)                        :: nt               ! number of coupling time steps to use in simulation

   REAL(DbKi)                            :: t                ! current time (s)
   REAL(DbKi)                            :: tMax             ! sim end time (s)
   REAL(DbKi)                            :: dtC              ! fixed/constant global time step
   REAL(DbKi)                            :: frac             ! fraction used in interpolation

   INTEGER(IntKi)                        :: MD_interp_order     ! order of interpolation/extrapolation

   ! Local variables
   Integer(IntKi)                        :: i                    ! counter for various loops
   Integer(IntKi)                        :: j                    ! counter for various loops
   Integer(IntKi)                        :: k                    ! counter for various loops
   Integer(IntKi)                        :: iIn
   integer(intKi)                        :: Un

   CHARACTER(20)                         :: FlagArg              ! flag argument from command line
   CHARACTER(1024)                       :: PlatformInitInputFile
   CHARACTER(200)                        :: git_commit    ! String containing the current git commit hash
   TYPE(ProgDesc), PARAMETER             :: version = ProgDesc( 'MoorDyn Driver', '', '' )

   CALL NWTC_Init( ProgNameIn=version%Name )

   MD_InitInput%FileName = "MoorDyn.dat"  ! initialize to empty string to make sure it's input from the command line
   CALL CheckArgs( MD_InitInput%FileName, Arg2=PlatformInitInputFile, Flag=FlagArg )
   IF ( LEN( TRIM(FlagArg) ) > 0 ) CALL NormStop()

      ! Display the copyright notice
   CALL DispCopyrightLicense( version%Name, 'Copyright (C) 2020 Matthew Hall' )
      ! Obtain OpenFAST git commit hash
   git_commit = QueryGitVersion()
      ! Tell our users what they're running
   CALL WrScr( ' Running '//TRIM( version%Name )//' a part of OpenFAST - '//TRIM(git_commit)//NewLine//' linked with '//TRIM( NWTC_Ver%Name )//NewLine )

   ! -------------------------------------------------------------------------
   ! Initialize MoorDyn
   ! -------------------------------------------------------------------------

   dtC = 0.01                   ! desired coupling time step size for communicating with MoorDyn

   MD_interp_order = 0

   ! MAP: allocate Input and Output arrays; used for interpolation and extrapolation
   Allocate(MD_InputTimes(MD_interp_order + 1))

   ! @bonnie : This is in the FAST developers glue code example, but it's probably not needed here.
   Allocate(MD_Input(MD_interp_order + 1))

   ! set the input file name and other environment terms.
   !MD_InitInput%NStepWave   = 1        ! an arbitrary number > 0 (to set the size of the wave data, which currently contains all zero values)
   MD_InitInput%g           = 9.81     ! This need to be according to g used in ElastoDyn
   MD_InitInput%rhoW        = 1025     ! This needs to be set according to seawater density in HydroDyn
   !MD_InitInput%PtfmInit    = 0.0
   MD_InitInput%RootName    = "MoorDyn.MD"

   CALL GetNewUnit( Un )
   OPEN(Unit=Un,FILE='MD.out',STATUS='UNKNOWN')
    !MD_InitInput%PtfmInit(1) = 1
    !MD_InitInput%PtfmInit(2) = 2
    !MD_InitInput%PtfmInit(3) = 3

    !����ʼ�����ɶ�--��ʼ���� ,�������ֳ�ʼ�������趨����һ��
    VesselFreedom1_Init = (/306.0, 265.0, 0.0, 0.0, 0.0,   0.0/)
    !VesselFreedom1_Init = (/1.0, 2.0, 0.0, 0.0, 0.0,   0.0/)
    VesselFreedom2_Init = (/306.0, -250.0, 0.0, 0.0, 0.0,  0.0/)
    VesselFreedom3_Init = (/-321.0, 227.0, 0.0, 0.0, 0.0,  0.0/)
    VesselFreedom4_Init = (/-201.0, -290.0, 0.0, 0.0, 0.0, 0.0/)

   !���˶��ٶ�--ʵʱ����
   VesselFairleadVe1 = (/0.1,0.0,0.0,0.0,0.0,0.0/)
   VesselFairleadVe2 = (/0.1,0.0,0.0,0.0,0.0,0.0/)
   VesselFairleadVe3 = (/0.05,0.0,0.0,0.0,0.0,0.0/)
   VesselFairleadVe4 = (/0.05,0.0,0.0,0.0,0.0,0.0/)

   !�������ɶ�--ʵʱ����
   VesselFreedom1 = (/306.0, 265.0, 0.0, 0.0, 0.0, 0.0/)
   !VesselFreedom1 = (/1.0, 2.0, 0.0, 0.0, 0.0,   0.0/)
   VesselFreedom2 = (/306.0, -250.0, 0.0, 0.0, 0.0,  0.0/)
   VesselFreedom3 = (/-321.0, 227.0, 0.0, 0.0, 0.0,  0.0/)
   VesselFreedom4 = (/-201.0, -290.0, 0.0, 0.0, 0.0, 0.0/)

  !����1-4��ʼ�����ɶ��趨
  CALL Set_Vessel_Freedom_Init(MD_InitInput, VesselFreedom1_Init,7)

  CALL Set_Vessel_Freedom_Init(MD_InitInput, VesselFreedom2_Init,8)

  CALL Set_Vessel_Freedom_Init(MD_InitInput, VesselFreedom3_Init,9)

  CALL Set_Vessel_Freedom_Init(MD_InitInput, VesselFreedom4_Init,10)

  ! call the initialization routine
   CALL MD_Init( MD_InitInput      , &
                   MD_Input(1)        , &
                   MD_Parameter       , &
                   MD_ContinuousState , &
                   MD_DiscreteState   , &
                   MD_ConstraintState , &
                   MD_OtherState      , &
                   MD_Output          , &
                   MD_MiscVar         , &
                   dtC                , &
                   MD_InitOutput      , &
                   ErrStat            , &
                   ErrMsg )
      IF ( ErrStat .NE. ErrID_None ) THEN
         IF (ErrStat >=AbortErrLev) CALL ProgAbort(ErrMsg)
         CALL WrScr( ErrMsg )
      END IF

   CALL MD_DestroyInitInput  ( MD_InitInput  , ErrStat, ErrMsg )
   CALL MD_DestroyInitOutput ( MD_InitOutput , ErrStat, ErrMsg )

   CALL DispNVD( MD_InitOutput%Ver )

   ncIn = 6 + size(MD_Input(1)%DeltaL)   ! determine number of input channels expected from driver input file time series (DOFs including active tensioning channels)

   ! -------------------------------------------------------------------------
   ! Read in prescribed motions from text file if available
   ! (single 6DOF platform for now, plus one active tensioning command)
   ! (to be updated for versatile coupling in future)
   ! -------------------------------------------------------------------------
   IF( LEN( TRIM(PlatformInitInputFile) ) < 1 ) THEN
      ntIn = 0   ! flag to indicate no motion input file
      print *, "No MoorDyn Driver input file provided, so using zero values."

   ELSE
      CALL GetNewUnit( UnPtfmMotIn )

      CALL OpenFInpFile ( UnPtfmMotIn, PlatformInitInputFile, ErrStat, ErrMsg )
      IF (ErrStat /= 0 ) THEN
         print *, ErrStat, ErrMsg
         STOP
      ENDIF

      print *, "Reading platform motion input data from ", PlatformInitInputFile

      ! Read through length of file to find its length
      i = 1  ! start counter
      DO
         READ(UnPtfmMotIn,'(A)',IOSTAT=ErrStat) Line      !read into a line

         IF (ErrStat /= 0) EXIT

         print *, TRIM(Line)

         i = i+1
      END DO

      ! rewind to start of input file to re-read things now that we know how long it is
      REWIND(UnPtfmMotIn)

      ntIn = i-1     ! save number of lines of file

      ! allocate space for input motion array (including time column)
      ALLOCATE ( PtfmMotIn(ntIn, ncIn+1), STAT = ErrStat )
      IF ( ErrStat /= ErrID_None ) THEN
         ErrMsg  = '  Error allocating space for PtfmMotIn array.'
         CALL WrScr( ErrMsg )
      END IF

      ! read the data in from the file
      DO i = 1, ntIn
         READ (UnPtfmMotIn,*,IOSTAT=ErrStat) (PtfmMotIn (i,J), J=1,ncIn+1)

         IF ( ErrStat /= 0 ) THEN
            ErrMsg = '  Error reading the input time-series file. Expecting '//TRIM(Int2LStr(ncIn))//' channels plus time.'
            CALL WrScr( ErrMsg )
         END IF
      END DO

         ! Close the inputs file
      CLOSE ( UnPtfmMotIn )

      print *, "Read ", ntIn, " time steps from input file."
      print *, PtfmMotIn

   END IF

   ! ----------------------- specify stepping details -----------------------

   IF (ntIn > 0) THEN
      tMax = PtfmMotIn(ntIn, 1)    ! save last time step as total sim time
   ELSE
      tMax = 60
   END IF

   nt = tMax/dtC - 1            ! number of coupling time steps

   CALL WrScr(" ")
   print *, "Tmax - ", tMax, " and nt=", nt
   CALL WrScr(" ")

   ! allocate space for processed motion array
   ALLOCATE ( PtfmMot(nt, ncIn), STAT = ErrStat )
   IF ( ErrStat /= ErrID_None ) THEN
      ErrMsg  = '  Error allocating space for PtfmMot array.'
      CALL WrScr( ErrMsg )
   END IF

   ! go through and interpolate inputs to new regular time steps (if nt=0 this array should be left as zeros)
   IF (ntIn > 0) THEN
      DO i = 1,nt

         t = dtC*(i-1)

         ! interpolation routine
         DO iIn = 1,ntIn-1
            IF (PtfmMotIn(iIn+1, 1) > t) THEN
               frac = (t - PtfmMotIn(iIn, 1) )/( PtfmMotIn(iIn+1, 1) - PtfmMotIn(iIn, 1) )

 !              print *, "t=", t, ", iIn=", iIn, ", frac=", frac

               DO J=1,ncIn
                  PtfmMot(i, J) = PtfmMotIn(iIn, J+1) + frac*(PtfmMotIn(iIn+1, J+1) - PtfmMotIn(iIn, J+1))
               END DO

               EXIT
            END IF
         END DO

 !        print *, t, "s", PtfmMot(i,:)

      END DO

   ELSE
      PtfmMot = 0.0_Reki
   END IF

   ! ---------------------------------------------------------------
   ! Set the initial input values
   ! ---------------------------------------------------------------
   ! start with zeros   >>> or should this be the initial row of DOFs? <<<
   MD_Input(1)%PtFairleadDisplacement%TranslationDisp = 0.0_ReKi
   MD_Input(1)%DeltaL = 0.0_ReKi
   MD_Input(1)%DeltaLdot = 0.0_ReKi

   DO i = 2, MD_interp_order + 1
      CALL MD_CopyInput( MD_Input(1), MD_Input(i), MESH_NEWCOPY, ErrStat, ErrMsg )
   END DO

   DO i = 1, MD_interp_order + 1
       MD_InputTimes(i) = -(i - 1) * dtC
   ENDDO

   t = 0

   CALL MD_CalcOutput(  t                  , &
                        MD_Input(1)        , &
                        MD_Parameter       , &
                        MD_ContinuousState , &
                        MD_DiscreteState   , &
                        MD_ConstraintState , &
                        MD_OtherState      , &
                        MD_Output          , &
                        MD_MiscVar         , &
                        ErrStat            , &
                        ErrMsg )
   IF ( ErrStat .NE. ErrID_None ) THEN
      IF (ErrStat >=AbortErrLev) CALL ProgAbort(ErrMsg)
      CALL WrScr( ErrMsg )
   END IF

  ! -------------------------------------------------------------------------
  ! BEGIN time marching  >>> note that 3 rotational platform DOFs are currently neglected <<<
  ! -------------------------------------------------------------------------

   print *,"Doing time marching now..."

   DO i = 1,nt

      ! --------------------------------- update inputs ---------------------------------

      t = dtC*(i-1)

      MD_InputTimes(1) = t + dtC

      ! also provide any active tensioning commands (just using delta L, and finite differencing to get derivative)
      DO j = 1,ncIn-6

         MD_Input(1)%DeltaL(j) =  PtfmMot(i, 6+j)

         IF (i>1) then
            MD_Input(1)%DeltaLdot(j) = (PtfmMot(i, 6+j) - PtfmMot(i-1, 6+j))/dtC
         ELSE
            MD_Input(1)%DeltaLdot(j) = 0.0_ReKi
         END IF

      END DO
      !����1-4�����ɶȼ��ٶ��趨
      CALL Set_Vessel_Freedom(MD_Input(1),MD_MiscVar,VesselFreedom1,VesselFairleadVe1,5)

      CALL Set_Vessel_Freedom(MD_Input(1),MD_MiscVar,VesselFreedom2,VesselFairleadVe2,6)

      CALL Set_Vessel_Freedom(MD_Input(1),MD_MiscVar,VesselFreedom3,VesselFairleadVe3,7)

      CALL Set_Vessel_Freedom(MD_Input(1),MD_MiscVar,VesselFreedom4,VesselFairleadVe4,8)
      WhichSpeed9 = -10
      WhichSpeed9 = -10
      !�趨������9��10���³���
      CALL Set_Line_length(MD_MiscVar,dtC, 5,WhichSpeed9)

      CALL Set_Line_length(MD_MiscVar,dtC, 6,WhichSpeed9)
      ! --------------------------------- update states ---------------------------------
      CALL  MD_UpdateStates(  t                  , &
                             nt                 , &
                             MD_Input           , &
                             MD_InputTimes      , &
                             MD_Parameter       , &
                             MD_ContinuousState , &
                             MD_DiscreteState   , &
                             MD_ConstraintState , &
                             MD_OtherState      , &
                             MD_MiscVar         , &
                             ErrStat              , &
                             ErrMsg )
      IF ( ErrStat .NE. ErrID_None ) THEN
         IF (ErrStat >=AbortErrLev) CALL ProgAbort(ErrMsg)
         CALL WrScr( ErrMsg )
         EXIT
      END IF

      ! update the global time step by one delta t               <<<< ??? why?
      t = t + dtC

      ! --------------------------------- calculate outputs ---------------------------------
      CALL MD_CalcOutput(  t                  , &
                          MD_Input(1)        , &
                          MD_Parameter       , &
                          MD_ContinuousState , &
                          MD_DiscreteState   , &
                          MD_ConstraintState , &
                          MD_OtherState      , &
                          MD_Output          , &
                          MD_MiscVar         , &
                          ErrStat              , &
                          ErrMsg )
      IF ( ErrStat .NE. ErrID_None ) THEN
         IF (ErrStat >=AbortErrLev) CALL ProgAbort(ErrMsg)
         CALL WrScr( ErrMsg )
      END IF
      !4�����¼�9��10��ê���������
      ALLOCATE ( Line1(3,MD_MiscVar%LineList(1)%N+1))
      ALLOCATE ( Line2(3,MD_MiscVar%LineList(2)%N+1))
      ALLOCATE ( Line3(3,MD_MiscVar%LineList(3)%N+1))
      ALLOCATE ( Line4(3,MD_MiscVar%LineList(4)%N+1))
      ALLOCATE ( Line5(3,MD_MiscVar%LineList(5)%N+1))
      ALLOCATE ( Line6(3,MD_MiscVar%LineList(6)%N+1))
      CALL Line_OUT(MD_MiscVar,Line1,Line2,Line3,Line4,Line5,Line6)
      !4�����µ��¿��������
      CALL FLines_OUT(MD_MiscVar,MD_Parameter,MD_Output,Flines1,Flines2,Flines3,Flines4)

      WRITE(Un,100) t, MD_Input(1)%PtFairleadDisplacement%TranslationDisp(1,1), ((MD_Output%PtFairleadLoad%Force(k,j), k=1,3),j=1,1)
      !WRITE(*,*) t_global

   END DO

   ! -------------------------------------------------------------------------
   ! END time marching
   ! -------------------------------------------------------------------------

   ! Destroy all objects
   CALL MD_End( MD_Input(1)       , &
                 MD_Parameter       , &
                 MD_ContinuousState , &
                 MD_DiscreteState   , &
                 MD_ConstraintState , &
                 MD_OtherState      , &
                 MD_Output          , &
                 MD_MiscVar         , &
                 ErrStat              , &
                 ErrMsg )
   IF ( ErrStat .NE. ErrID_None ) THEN
      IF (ErrStat >=AbortErrLev) CALL ProgAbort(ErrMsg)
      CALL WrScr( ErrMsg )
   END IF

   do j = 2,MD_interp_order+1
      call MD_DestroyInput( MD_Input(j), ErrStat, ErrMsg)
   end do

   DEALLOCATE(MD_Input)
   DEALLOCATE(MD_InputTimes)

   IF (ALLOCATED(PtfmMot)  ) DEALLOCATE(PtfmMot  )
   IF (ALLOCATED(PtfmMotIn)) DEALLOCATE(PtfmMotIn)

   CALL WrScr( "Program has ended" )
   close (un)

100 FORMAT(2(1X,F8.3),9(1X,E12.5))

 END PROGRAM


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

program convert_gpsro_bufr

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   convert_gpsro_bufr - program that reads a COSMIC GPS observation
!                        in BUFR format and writes the data to a DART
!                        observation sequence file.
!
!   For platforms with little-endian binary file format (e.g. Intel, AMD®, and
!   non-MIPS SGI processors), you may need to first run the byte-swapping program
!   DART/observations/NCEP/prep_bufr/exe/grabbufr.x over the bufr file
!   before running this program. For the info, check
!   DART/observations/NCEP/prep_bufr/prep_bufr.html.
!
!   created August 2015 Soyoung Ha, NCAR/MMM
!
!   Tested with gdas.gpsro.2012060100 for local operator only.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

use          types_mod, only : r8,r4,digits12
use   time_manager_mod, only : time_type, set_calendar_type, GREGORIAN, set_time,&
                               increment_time, get_time, set_date, operator(-),  &
                               operator(>=), operator(<), operator(>), operator(<=), &
                               print_date, decrement_time
use      utilities_mod, only : initialize_utilities, find_namelist_in_file,    &
                               check_namelist_read, nmlfileunit, do_nml_file,  &
                               get_next_filename, error_handler, E_ERR, E_MSG, &
                               find_textfile_dims, do_nml_term, open_file, close_file
use  netcdf_utilities_mod, only : nc_check
use       location_mod, only : VERTISHEIGHT, set_location
use   obs_sequence_mod, only : obs_sequence_type, obs_type, read_obs_seq,       &
                               static_init_obs_sequence, init_obs, destroy_obs, &
                               write_obs_seq, init_obs_sequence, get_num_obs,   &
                               insert_obs_in_seq, destroy_obs_sequence,         &
                               set_copy_meta_data, set_qc_meta_data, set_qc,    &
                               set_obs_values, set_obs_def, read_obs_seq_header
use   obs_def_mod,      only : obs_def_type, set_obs_def_time, set_obs_def_type_of_obs, &
                               set_obs_def_error_variance, set_obs_def_location, &
                               set_obs_def_key
use    obs_def_gps_mod, only : set_gpsro_ref
use       obs_kind_mod, only : GPSRO_REFRACTIVITY
use  obs_utilities_mod, only : add_obs_to_seq

implicit none

! version controlled file description for error handling, do not edit
character(len=*), parameter :: source   = "$URL$"
character(len=*), parameter :: revision = "$Revision$"
character(len=*), parameter :: revdate  = "$Date$"

! routines used from the bufrlib.a library:
!    openbf, datelen, readmg,  ireadmg, ireadsb
!    ufbint, ireadsb, ireadmg, closbf
!    upftbv, ufbint,  ufbseq
! be careful about passing real values across to these routines.
! they are compiled without using our r4 and r8 kinds.  if r8=r4
! you must use digits12 when passing real arrays.

integer, parameter ::   num_copies = 1,   &   ! number of copies in sequence
                        num_qc     = 1        ! number of QC entries

character (len=512) :: msgstring
character (len=256) :: next_infile
character (len=6)   :: subset
integer :: nlevels, nfiles, num_new_obs, oday, osec, &
           iyear, imonth, iday, ihour, imin, obs_count, gps_obs_num, obs_num_byfile, &
           io, iunit, filenum, dummy
logical :: file_exist, first_obs, from_list = .false.
real(r8) :: oerr, qc, nx, ny, nz, &
            rfict, obsval, obs_val(1), qc_val(1)

type(obs_def_type)      :: obs_def
type(obs_sequence_type) :: obs_seq
type(obs_type)          :: obs, prev_obs
type(time_type)         :: obs_time, prev_time
type(time_type)         :: anal_time, window_min, window_max

integer :: gday, gsec, dsec, bsec, bday, esec, eday, num_excluded_bytime
integer :: existing_obs
logical :: use_bending_angle = .false.      ! Reserve for later.

! unused vars required by an interface that doesn't allow optional args
integer :: dummy_a, dummy_b, dummy_c, dummy_d
logical :: dummy_tf
character(len=32) :: dummy_str

!------------------------------------------------------------------------
! Array for bufr data
!------------------------------------------------------------------------
character(len=80)  hdr1a
character(len=10)  nemo
character(len=8)   subsetb
character(len=1)   cflg
character(len=7)   obstype
character(len=120) crecord

integer :: unit_in
integer :: unit_aux
integer, parameter:: n1ahdr=10
integer, parameter:: maxlevs=500    ! max number of observation levels (no longer namelist parameter)
integer, parameter:: maxinfo=16
integer, parameter:: mxib=31
integer, dimension(50):: isats

integer :: ireadmg,ireadsb   ! functions from bufr routines that return integers
integer :: num_satid, nk
integer :: idate,iret,num_message,num_subset
integer :: ikx, nlevs, nreps_ROSEQ1
integer :: i,k,m,said,ptid
integer :: nprof_gps,nprof_bytime,nprof_bad
integer :: nprof_nosat,nprof_cdaac_bad,nprof_gras_bad,nprof_levs_bad
integer :: ibit(mxib),nib
integer :: nsatid,nlines,istat
integer :: isatid,isub,iuse

real(r8) :: pcc, roc, impact, geopot
real(r8) :: height,rlat,rlon,ref,referr,ref_pccf
real(r8) :: freq_chk,freq,bend,bend_error,bend_pccf

! these are passed to the bufr library and must be 8 bytes even
! if this converter is compiled with reals = r4
real(digits12), dimension(n1ahdr):: hdr
real(digits12), dimension(1)     :: qfro
real(digits12), dimension(maxlevs):: nreps_this_ROSEQ2
real(digits12), dimension(50,maxlevs):: data1b
real(digits12), dimension(50,maxlevs):: data2a

integer, allocatable, dimension(:):: gps_satid

! not in namelist anymore?  doesn't have to be a parameter;
! could be added back to namelist if needed.
integer, parameter:: max_num_obs=200000    ! max number of observations / input file

logical :: lone, good

!------------------------------------------------------------------------
!  Declare namelist parameters
!------------------------------------------------------------------------
real(r8) :: ray_hbot =  3000.0_r8     ! lowest level (meter)
real(r8) :: ray_htop = 30000.0_r8     ! highest level (m) for observation
real(r8) :: ray_ds                    ! No longer used. Just keep for set_gpsro_ref now.
real(r8) :: obs_window_hr = -1.0      ! observation time window (+/-hours); A negative value means taking all the observations regardless of their report time.
real(r8) :: gsi_error_inv_factor = 1.0     ! scale factor for the inverse of gsi error
logical  :: if_global = .true.               ! Is your forecast model a regional or a global model?
logical  :: obs_error_in_gsi = .true.        ! obs error is overwritten as one percent of the refractivity obs value
logical  :: convert_to_geopotential_height = .false.  ! convert geometric height in bufr data to geopotential height?
logical  :: debug = .false.
character(len=128) :: gpsro_bufr_file     = 'gdas.gpsro.bufr'
character(len=128) :: gpsro_bufr_filelist = 'list_gpsro_bufr'
character(len=128) :: gpsro_out_file      = 'obs_seq.gpsro'
character(len=128) :: gpsro_aux_file      = 'convinfo.txt'         ! gps satellite info (from GSI)

namelist /convert_gpsro_bufr_nml/ ray_htop, ray_hbot, obs_window_hr, if_global, &
                                  obs_error_in_gsi, convert_to_geopotential_height, &
                                  gsi_error_inv_factor, &
                                  gpsro_bufr_file, gpsro_bufr_filelist, &
                                  gpsro_out_file,  gpsro_aux_file, debug

!------------------------------------------------------------------------
! start of executable code
!------------------------------------------------------------------------

 ! these are unused with the local operator, but would be required if
 ! you wanted to do the computation for the non-local operator.
 nx        = 0.0_r8
 ny        = 0.0_r8
 nz        = 0.0_r8
 rfict     = 0.0_r8
 data hdr1a / 'YEAR MNTH DAYS HOUR MINU PCCF ELRC SAID PTID GEODU' /
 data nemo /'QFRO'/

!------------------------------------------------------------------------
! Open and read the auxiliary info (mainly for satellite id to be used)
!------------------------------------------------------------------------

 unit_aux = open_file(gpsro_aux_file, action='read', form='formatted')

 rewind(unit_aux)
 nsatid=0
 nlines=0
 read1: do
        read(unit_aux,1030,iostat=istat,end=1130) cflg,obstype,crecord
        if (istat /= 0) exit
        nlines=nlines+1
        if(cflg == '!') cycle
        if(trim(obstype) /= 'gps') cycle    ! We process gps only.
        read(crecord,*) isatid,isub,iuse
        if (iuse < 0) cycle       ! Soyoung: -1 for monitoring. We skip it.
        nsatid=nsatid+1
        isats(nsatid)=isatid
 enddo read1
 1030 format(a1,a7,2x,a120)
 1130 continue
 if (istat>0) then
    write(msgstring,*) 'error reading convinfo from file "'//trim(gpsro_aux_file)//'"', ' istat=',istat
    call error_handler(E_ERR, 'convert_gpsro_bufr', msgstring, &
                       source, revision, revdate)
 endif
 call close_file(unit_aux)

 num_satid=nsatid
 allocate(gps_satid(num_satid))
 gps_satid(1:num_satid)=isats(1:num_satid)
 if (debug) write(*,'(A,20I5)') 'convert_gpsro_bufr: satellite id:',gps_satid

!------------------------------------------------------------------------
! initialize some values
!------------------------------------------------------------------------
obs_count = 0
qc = 0.0_r8
first_obs = .true.
call set_calendar_type(GREGORIAN)

!  read the necessary parameters from input.nml
call initialize_utilities()

call find_namelist_in_file("input.nml", "convert_gpsro_bufr_nml", iunit)
read(iunit, nml = convert_gpsro_bufr_nml, iostat = io)
call check_namelist_read(iunit, io, "convert_gpsro_bufr_nml")

! Record the namelist values used for the run
if (do_nml_file()) write(nmlfileunit, nml=convert_gpsro_bufr_nml)
if (do_nml_term()) write(     *     , nml=convert_gpsro_bufr_nml)

!  FIXME: We take all the native observation levels (instead of interpolating to
!  the levels at regular intervals.
!  Then, how to count observation levels from each profile? (e.g., nlevels)
!  For now, we take maxlevs as num_new_obs, and are not sure if gpsro_bufr_filelist
!  would work with it.
!nlevels = maxlevs

! namelist checks for sanity

! cannot have both a single filename and a list; the namelist must
! shut one off.
if (gpsro_bufr_file /= '' .and. gpsro_bufr_filelist /= '') then
  call error_handler(E_ERR, 'convert_gpsro_bufr',                     &
                    'One of gpsro_bufr_file or filelist must be NULL', &
                     source, revision, revdate)
endif
if (gpsro_bufr_filelist /= '') from_list = .true.

if ( obs_window_hr > 0.0 ) then
     print '(A,F5.2)', "Limit gpsro data within the time window (+/- hours): ", obs_window_hr
     print*, "Enter target assimilation time (gregorian day, second): "
     read*, gday,gsec

     call set_calendar_type(GREGORIAN)
     anal_time = set_time(gsec, gday)
     dsec = nint(obs_window_hr * 3600.)
     window_min = decrement_time(anal_time, dsec)
     window_max = increment_time(anal_time, dsec)
     call get_time(window_min,bsec,bday)
     call get_time(window_max,esec,eday)

     print '(2(A,2I8))', 'Observations are taken between ',bday,bsec,' and ',eday,esec
     num_excluded_bytime = 0   ! total number of obs beyond the time window
endif

! need to know a reasonable max number of obs that could be added here.
if (from_list) then
   call find_textfile_dims(gpsro_bufr_filelist, nfiles, dummy)
   num_new_obs = max_num_obs * nfiles
else
   num_new_obs = max_num_obs           !maxlevs
endif

!  either read existing obs_seq or create a new one
call static_init_obs_sequence()
call init_obs(obs, num_copies, num_qc)
call init_obs(prev_obs, num_copies, num_qc)
inquire(file=gpsro_out_file, exist=file_exist)

! blank line for readability
call error_handler(E_MSG, '', '', source, revision, revdate)

if ( file_exist ) then

   write(msgstring, *) 'Found existing obs_seq file, will append obs to "'//trim(gpsro_out_file)//'"'
   call error_handler(E_MSG, 'convert_gpsro_bufr', msgstring, source, revision, revdate)

   ! open the file and figure out how many obs are already there
   call read_obs_seq_header(gpsro_out_file, dummy_a, dummy_b, existing_obs, &
      dummy_c, dummy_d, dummy_str, dummy_tf, close_the_file = .true.)

   write(msgstring, *) "Existing file already contains ", existing_obs, " observations."
   call error_handler(E_MSG, 'convert_gpsro_bufr', msgstring, source, revision, revdate)

   ! blank line
   call error_handler(E_MSG, '', '', source, revision, revdate)

   ! reopen the file and tell it how many obs we potentially will be adding
   call read_obs_seq(gpsro_out_file, 0, 0, num_new_obs, obs_seq)

else

   write(msgstring, *) 'Creating new obs_seq file "'//trim(gpsro_out_file)//'"'
   call error_handler(E_MSG, 'convert_gpsro_bufr', msgstring, source, revision, revdate)

   write(msgstring, *) 'Maximum observation count to be added is ', num_new_obs
   call error_handler(E_MSG, 'convert_gpsro_bufr', msgstring, source, revision, revdate)

   ! blank line
   call error_handler(E_MSG, '', '', source, revision, revdate)

   ! create the new obs sequence here
   call init_obs_sequence(obs_seq, num_copies, num_qc, num_new_obs)

   call set_copy_meta_data(obs_seq, 1, 'COSMIC GPS observation')
   call set_qc_meta_data(obs_seq, 1, 'COSMIC QC')

end if

!------------------------------------------------------------------------
! main loop that does either a single file or a list of files
!------------------------------------------------------------------------

filenum = 1
fileloop: do      ! until out of files

   ! do some bookkeeping to see how many scans are ignored and for what reason.
   ! the print for these is inside the fileloop so the reset has to be inside
   ! as well.  if you want totals for the entire run (including multiple files)
   ! take these out of the loop and move the prints out of the loop at the bottom

   obs_num_byfile = 0
   nprof_gps = 0
   nprof_bytime = 0
   nprof_cdaac_bad = 0
   nprof_gras_bad = 0
   nprof_levs_bad = 0
   nprof_nosat = 0

   ! get the single name, or the next name from a list
   if (from_list) then
      next_infile = get_next_filename(gpsro_bufr_filelist, filenum)
   else
      next_infile = gpsro_bufr_file
      if (filenum > 1) next_infile = ''
   endif
   if (next_infile == '') exit fileloop

   !------------------------------------------------------------------------
   ! Open file for input
   !------------------------------------------------------------------------
   unit_in = open_file(next_infile, action='read', form='unformatted')

   !------------------------------------------------------------------------
   ! Reading bufr data
   !------------------------------------------------------------------------
   call openbf(unit_in,'IN',unit_in)          ! BUFRLIB
   call datelen(10)                           ! BUFRLIB
   call readmg(unit_in,subsetb,idate,iret)    ! BUFRLIB
   if (iret /= 0) goto 1010

   ! Big loop over the bufr file
   num_message=0
   msg_report: do while (ireadmg(unit_in,subsetb,idate) == 0)   ! BUFRLIB
     num_message = num_message + 1
     num_subset = 0
     if (debug) write(*,'(I10,I5,a10)') idate,num_message,subsetb

     read_loop: do while (ireadsb(unit_in) == 0)                ! BUFRLIB
       num_subset = num_subset+1

       ! Extract header information
       call ufbint(unit_in,hdr,n1ahdr,1,iret,hdr1a)             ! BUFRLIB
       call ufbint(unit_in,qfro,1,1,iret,nemo)                  ! BUFRLIB

       ! observation time in minutes
       iyear  = hdr(1) ! year
       imonth = hdr(2) ! month
       iday   = hdr(3) ! day
       ihour  = hdr(4) ! hour
       imin   = hdr(5) ! minute
       pcc=hdr(6)         ! profile per cent confidence
       roc=hdr(7)         ! Earth local radius of curvature
       said=hdr(8)        ! Satellite identifier (receiver)
       ptid=hdr(9)        ! Platform transmitter ID number

       if (debug) write(*,*) iyear, imonth, iday, ihour, imin
       obs_time = set_date(iyear, imonth, iday, ihour, imin, 0)
       call get_time(obs_time,  osec, oday)

       ! Check the satellite list in convinfo
       ikx = 0
       find_loop: do i = 1, num_satid
          if ( said == gps_satid(i) ) then
               ikx = 1
               exit find_loop
          endif
       enddo find_loop
       if (ikx==0) then
           nprof_nosat = nprof_nosat + 1
           cycle read_loop
       endif

       ! Check profile quality flags
       if ( ((said > 739).and.(said < 746)).or.(said == 820).or.(said == 786)) then  !CDAAC processing
           if(pcc==0.0) then
              if (debug) write(*,*)'convert_gpsro_bufr: 1 bad profile said=',said,'ptid=',ptid,&
                                   ' SKIP this report'
              nprof_cdaac_bad = nprof_cdaac_bad + 1
              cycle read_loop
           endif
        endif

        if ((said == 4).or.(said == 3).or.(said == 421).or.(said == 440).or.&
            (said == 821)) then ! GRAS SAF processing
           call upftbv(unit_in,nemo,qfro,mxib,ibit,nib)         ! BUFRLIB
           lone = .false.
           if(nib > 0) then
              do i=1,nib
                 if(ibit(i)== 6) then
                    lone = .true.
                    exit
                 endif
              enddo
           endif
           if(lone) then
              if (debug) write(*,*) 'convert_gpsro_bufr: 2 bad profile said=',said,'ptid=',ptid,&
                                    ' SKIP this report'
              nprof_gras_bad = nprof_gras_bad + 1
              cycle read_loop
           endif
        endif

       ! Read observations
       call ufbint(unit_in,nreps_this_ROSEQ2,1,maxlevs,nreps_ROSEQ1,'{ROSEQ2}')        ! BUFRLIB
       call ufbseq(unit_in,data1b,50,maxlevs,  nlevs,'ROSEQ1')    ! bending angle      ! BUFRLIB
       call ufbseq(unit_in,data2a,50,maxlevs,nlevels,'ROSEQ3')    ! refractivity       ! BUFRLIB
       if (nlevs/=nlevels) then
          if (debug) write(*,'(A,2I5,2(A,I5),A)') 'convert_gpsro_bufr:  *WARNING* said,ptid=',said,ptid,&
                                                  ' with gps_bnd nlevs=', nlevs,&
                                                  ' and gps_ref nlevels=',nlevels,&
                                                  ' SKIP this report'
          nprof_levs_bad = nprof_levs_bad + 1
          cycle read_loop
       endif

       ! Exclude observations outside the time window.
       if ( obs_window_hr > 0.0 ) then
          if (obs_time <= window_min .or. obs_time > window_max ) then
              num_excluded_bytime = num_excluded_bytime + nlevels
              nprof_bytime = nprof_bytime + 1
              cycle read_loop
          end if
       end if

       ! Increment report counters
       nprof_gps = nprof_gps + 1      ! count reports in bufr file
       if (debug) write(*,'(5(A8,I5))') ' nprof =',nprof_gps,' said =',said,' ptid=',ptid,&
                                        ' nlevs =',nlevs,' nlevels =',nlevels

       ! Loop over nlevels in profile
       obsloop2: do k = 1, nlevels

          rlat=data1b(1,k)      ! earth relative latitude (degrees)
          rlon=data1b(2,k)      ! earth relative longitude (degrees)
          height=data2a(1,k)    ! geometric height above geoid (m)
          ref=data2a(2,k)       ! refractivity obs (units of N)
          referr=data2a(4,k)    ! gps ref obs error (units of N)
          ref_pccf=data2a(6,k)  ! percent confidence (%)

          if(use_bending_angle) then        ! for later

          ! Loop over number of replications of ROSEQ2 nested inside ROSEQ1
          nk = nreps_this_ROSEQ2(k)
          do i=1,nk
              m=(6*i)-2
              freq_chk=data1b(m,k)          ! frequency (hertz)
              if(nint(freq_chk).ne.0) cycle ! do not want non-zero freq., go on
                                            ! to next replication of ROSEQ2
              freq=data1b(m,k)
              impact=data1b(m+1,k)      ! impact parameter (m)
              bend=data1b(m+2,k)        ! bending angle (rad)
              bend_error=data1b(m+4,k)  ! RMSE in bending angle (rad)
          enddo
          bend_pccf=data1b((6*nk)+4,k)  ! percent confidence for this ROSEQ1 replication

          endif     !if(use_bending_angle) then

          ! Preliminary (sanity) checks for bad and missing data
          good=.true.
          if ((abs(rlat)>90.0_r8).or.(abs(rlon)>360.0_r8)) good=.false.
          if ((ref>=1.e+9_r8).or.(ref<=0.0_r8))            good=.false.
          if ((height<=ray_hbot).or.(height>=ray_htop))    good=.false.
          ! Remove MetOP/GRAS ata below 8 km (following GSI)
          if ((height<=8000.0_r8).and.((said==4).or.(said==3))) good=.false.

          if(use_bending_angle) then
          if ((bend>=1.e+9_r8).or.(bend<=0.0).or.(impact>=1.e+9_r8).or.(impact<roc)) then
               good=.false.
          endif
          endif

          ! If observation is "good" print out sample data
          if(good) then

            obsval = ref    ! unit "N"

            geopot = compute_geopotential_height(height,rlat)

            if(obs_error_in_gsi) then
               !oerr   = 0.01_r8 * obsval
               oerr   = gsi_refractivity_error(height, rlat, if_global, gsi_error_inv_factor)
            else
               oerr   = 0.01_r8 * ref_obserr_kuo_percent(height * 0.001_r8) * obsval
            endif
            subset = 'GPSREF'

            if(use_bending_angle) then
               obsval = bend
               if((impact-roc) <= 10000.0_r8) then
                   oerr=(-bend*0.09/10000.0_r8)*(impact-roc)+bend*1.e-1_r8
               else
                   oerr=max(7.e-6_r8,bend*1.e-2_r8)
               endif
            endif

            if(rlon==360.0_r8) rlon=0.0_r8
            if(rlon < 0.0_r8)  rlon=rlon+360.0_r8

            if(debug.and.(k.lt.10)) then
               if(use_bending_angle) then
                  write(*,'(A2,I5,4f9.2,f20.3)') 'k=',k,rlat,rlon,height,bend,oerr
               else
                  write(*,'(A2,I5,6f9.2)') 'k=',k,rlat,rlon,height,ref,oerr,referr
               endif
            endif

            if(convert_to_geopotential_height) height = geopot

            ! the first arg here is intent(out), and is passed back in to set_obs_def_key()
            call set_gpsro_ref(gps_obs_num, nx, ny, nz, rfict, ray_ds, ray_htop, subset)
            call set_obs_def_location(obs_def,set_location(rlon,rlat,height,VERTISHEIGHT))
            call set_obs_def_type_of_obs(obs_def, GPSRO_REFRACTIVITY)
            call set_obs_def_time(obs_def, set_time(osec, oday))
            call set_obs_def_error_variance(obs_def, oerr * oerr)
            call set_obs_def_key(obs_def, gps_obs_num)
            call set_obs_def(obs, obs_def)

            obs_val(1) = obsval
            call set_obs_values(obs, obs_val)
            qc_val(1)  = qc
            call set_qc(obs, qc_val)

            call add_obs_to_seq(obs_seq, obs, obs_time, prev_obs, prev_time, first_obs)

            obs_count = obs_count+1
            obs_num_byfile = obs_num_byfile + 1

          endif    !(good) then
       end do obsloop2                   ! End of k loop over nlevels

       if (debug) write(*,*)
     enddo read_loop            ! subsets
   enddo msg_report             ! messages

1010 continue

   !------------------------------------------------------------------------
   ! Close unit to input file and write out some summary statistics for
   ! this file.
   !------------------------------------------------------------------------
   call closbf(unit_in)     ! BUFRLIB

   ! blank line
   call error_handler(E_MSG, '', '', source, revision, revdate)

   write(msgstring, *) 'Processed input file "'//trim(next_infile)//'", summary:'
   call error_handler(E_MSG, 'convert_gpsro_bufr', msgstring, source, revision, revdate)

   write(msgstring, *) '  Number of obs created = ',obs_num_byfile
   call error_handler(E_MSG, 'convert_gpsro_bufr', msgstring, source, revision, revdate)

   write(msgstring, *) '  Total number of profiles = ', nprof_gps
   call error_handler(E_MSG, 'convert_gpsro_bufr', msgstring, source, revision, revdate)

   nprof_bad = nprof_cdaac_bad + nprof_gras_bad + nprof_levs_bad + nprof_bytime + nprof_nosat
   write(msgstring, *) '  Total number of skipped profiles = ', nprof_bad
   call error_handler(E_MSG, 'convert_gpsro_bufr', msgstring, source, revision, revdate)

   write(msgstring, *) 'Skipped profile summary:'
   call error_handler(E_MSG, 'convert_gpsro_bufr', msgstring, source, revision, revdate)

   write(msgstring, *) '  Bad CDAAC code: ', nprof_cdaac_bad
   call error_handler(E_MSG, 'convert_gpsro_bufr', msgstring, source, revision, revdate)

   write(msgstring, *) '  Bad GRAS code: ', nprof_gras_bad
   call error_handler(E_MSG, 'convert_gpsro_bufr', msgstring, source, revision, revdate)

   write(msgstring, *) '  Bad level counts: ', nprof_levs_bad
   call error_handler(E_MSG, 'convert_gpsro_bufr', msgstring, source, revision, revdate)

   write(msgstring, *) '  Excluded by time: ', nprof_bytime
   call error_handler(E_MSG, 'convert_gpsro_bufr', msgstring, source, revision, revdate)

   write(msgstring, *) '  Excluded by satellite id: ', nprof_nosat
   call error_handler(E_MSG, 'convert_gpsro_bufr', msgstring, source, revision, revdate)

   call error_handler(E_MSG, '', '', source, revision, revdate)

   ! move on to the next file
   filenum = filenum + 1

end do fileloop

! done with main loop.  if we added any new obs to the sequence, write it out.
if (obs_count > 0) then
   call write_obs_seq(obs_seq, gpsro_out_file)

   if (file_exist) then
      write(msgstring, *) obs_count, ' observations added to obs_seq file "'//trim(gpsro_out_file)//'"'
      call error_handler(E_MSG, 'convert_gpsro_bufr', msgstring, source, revision, revdate)

      write(msgstring, *) 'File should now contain ', obs_count + existing_obs, ' observations.'
      call error_handler(E_MSG, 'convert_gpsro_bufr', msgstring, source, revision, revdate)
   else
      write(msgstring, *) obs_count, ' observations written to obs_seq file "'//trim(gpsro_out_file)//'"'
      call error_handler(E_MSG, 'convert_gpsro_bufr', msgstring, source, revision, revdate)
   endif
else
   write(msgstring, *) 'No observations found. None written to obs_seq file "'//trim(gpsro_out_file)//'"'
   call error_handler(E_MSG, 'convert_gpsro_bufr', msgstring, source, revision, revdate)
endif

! blank line
call error_handler(E_MSG, '', '', source, revision, revdate)

! cleanup memory
call destroy_obs_sequence(obs_seq)
call destroy_obs(obs)   ! do not destroy prev_obs, which is same as obs
deallocate(gps_satid)

! END OF MAIN ROUTINE

contains

! local subroutines/functions follow

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   ref_obserr_kuo_percent - function that computes the observation
!                            error for a refractivity observation.
!                            These numbers are taken from a Kuo paper.
!
!    hght - height of refractivity observation
!
!     created Hui Liu NCAR/MMM
!     modified June 2008, Ryan Torn NCAR/MMM
!     modified August 2015, Soyoung Ha NCAR/MMM
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function ref_obserr_kuo_percent(hght)

use   types_mod, only : r8

implicit none

integer, parameter :: nobs_level = 22  !  maximum number of obs levels

real(r8), intent(in)  :: hght

integer  :: k, k0
real(r8) :: hght0, ref_err(nobs_level), obs_ht(nobs_level), ref_obserr_kuo_percent

!   observation error heights (km) and errors
data obs_ht/17.98_r8, 16.39_r8, 14.97_r8, 13.65_r8, 12.39_r8, 11.15_r8, &
             9.95_r8,  8.82_r8,  7.82_r8,  6.94_r8,  6.15_r8,  5.45_r8, &
             4.83_r8,  4.27_r8,  3.78_r8,  3.34_r8,  2.94_r8,  2.59_r8, &
             2.28_r8,  1.99_r8,  1.00_r8,  0.00_r8/

data ref_err/0.48_r8,  0.56_r8,  0.36_r8,  0.28_r8,  0.33_r8,  0.41_r8, &
             0.57_r8,  0.73_r8,  0.90_r8,  1.11_r8,  1.18_r8,  1.26_r8, &
             1.53_r8,  1.85_r8,  1.81_r8,  2.08_r8,  2.34_r8,  2.43_r8, &
             2.43_r8,  2.43_r8,  2.43_r8,  2.43_r8/

hght0 = max(hght, 0.0_r8)

do k = 1, nobs_level

  k0 = k
  if ( hght0 >= obs_ht(k) )  exit

end do

if(k0.eq.1) then    ! HA
   ref_obserr_kuo_percent = ref_err(k0)
else
   ref_obserr_kuo_percent = ref_err(k0) + (ref_err(k0) - ref_err(k0-1)) / &
                           (obs_ht(k0)-obs_ht(k0-1)) * (hght0-obs_ht(k0))
endif

return
end function ref_obserr_kuo_percent

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!    compute_geopotential_height
!    subroutine converts geometric height to geopotential height
!
!    Input:
!    H   -- input real value geometric height [m]
!    lat -- latitude in degree
!
!    Output:
!    Z -- output real value geopotential height [m]
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function compute_geopotential_height(H, lat)
 real(r8), intent(in)  :: H
 real(r8), intent(in)  :: lat
 real(r8)              :: compute_geopotential_height

! -----------------------------------------------------------------------*/
   real(r8) :: pi2, latr
   real(r8) :: semi_major_axis, semi_minor_axis, grav_polar, grav_equator
   real(r8) :: earth_omega, grav_constant, flattening, somigliana
   real(r8) :: grav_ratio, sin2, termg, termr, grav, eccentricity

!  Parameters below from WGS-84 model software inside GPS receivers.
   parameter(semi_major_axis = 6378.1370d3)    ! (m)
   parameter(semi_minor_axis = 6356.7523142d3) ! (m)
   parameter(grav_polar = 9.8321849378)        ! (m/s2)
   parameter(grav_equator = 9.7803253359)      ! (m/s2)
   parameter(earth_omega = 7.292115d-5)        ! (rad/s)
   parameter(grav_constant = 3.986004418d14)   ! (m3/s2)
   parameter(grav = 9.80665d0)                 ! (m/s2) WMO std g at 45 deg lat
   parameter(eccentricity = 0.081819d0)        ! unitless
   parameter(pi2 = 3.14159265358979d0/180.d0)

!  Derived geophysical constants
   parameter(flattening = (semi_major_axis-semi_minor_axis) / semi_major_axis)

   parameter(somigliana = (semi_minor_axis/semi_major_axis)*(grav_polar/grav_equator)-1.d0)

   parameter(grav_ratio = (earth_omega*earth_omega * &
                semi_major_axis*semi_major_axis * semi_minor_axis)/grav_constant)

!  Sanity Check
   if(lat.gt.90 .or. lat.lt.-90) then
      print*, 'compute_geopotential_height: Latitude is not between -90 and 90 degrees: ',lat
      return
   endif

   latr = lat * (pi2)        ! in radians
   sin2  = sin(latr) * sin(latr)
   termg = grav_equator * ( (1.d0+somigliana*sin2) / &
           sqrt(1.d0-eccentricity*eccentricity*sin2) )
   termr = semi_major_axis / (1.d0 + flattening + grav_ratio - 2.d0*flattening*sin2)

   compute_geopotential_height = (termg/grav)*((termr*H)/(termr+H))
   !print '(A,3f15.5)','compute_geopotential_height:',&
   !                   H,compute_geopotential_height,H-compute_geopotential_height

end function compute_geopotential_height

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   gsi_refractivity_error - function that computes the observation
!                            error as in GSI
!
!    Input:
!    H   -- input real value geometric height [m]
!    lat -- latitude in degree
!    is_it_global -- is your forecast model regional or global? (T or F)
!
!    Output:
!    gsi_refractivity_error -- output refractivity observation error [N]
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function gsi_refractivity_error(H, lat, is_it_global, factor)
 real(r8), intent(in)  :: H
 real(r8), intent(in)  :: lat
 real(r8), intent(in)  :: factor
 logical,  intent(in)  :: is_it_global
 real(r8)              :: gsi_refractivity_error

 real(r8) :: zkm, rerr

 zkm = H * 0.001       ! height in km
 rerr = 1.0_r8

 if(is_it_global) then    ! for global

 if((lat >= 20.0_r8) .or. (lat <= -20.0_r8)) then
    rerr = -1.321_r8 + 0.341_r8 * zkm - 0.005_r8 * zkm ** 2
 else
    if(zkm > 10.0_r8) then
       rerr = 2.013_r8 - 0.060_r8 * zkm + 0.0045_r8 * zkm ** 2
    else
       rerr = -1.18_r8 + 0.058_r8 * zkm + 0.025_r8 * zkm ** 2
    endif
 endif

 else     ! for regional

 if((lat >= 20.0_r8) .or. (lat <= -20.0_r8)) then
    if(zkm > 10.0_r8) then
       rerr = -1.321_r8 + 0.341_r8 * zkm - 0.005_r8 * zkm ** 2
    else
       rerr = -1.2_r8 + 0.065_r8 * zkm + 0.021_r8 * zkm ** 2
    endif
 endif

 endif    ! if(is_it_global) then

 gsi_refractivity_error = 1./(abs(exp(rerr))*factor)
 !gsi_refractivity_error = 1./abs(exp(rerr))

 return
end function gsi_refractivity_error

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
end program


module da_verif_anal_control
   !----------------------------------------------------------------------------
   ! History:
   !
   ! Author:   Syed RH Rizvi     NCAR/MMM       10/08/2007
   !
   ! Abstract: Main module for defining and initializing various constants,
   !   namelist variables etc.
   !
   !----------------------------------------------------------------------------

  implicit none

  integer, parameter                     :: max_3d_variables = 6
  integer, parameter                     :: max_2d_variables = 6
  integer, parameter                     :: num_vert_levels = 100
  integer, parameter                     :: max_num_scores = 3
  integer, parameter                     :: max_num_exps = 10
  real, parameter                        :: missing=1.0E35
!-----------------------------------------------------------------
  integer, parameter                     :: namelist_unit = 7
  integer, parameter                     :: input_file_unit = 9
  integer, parameter                     :: first_unit = 11
  integer, parameter                     :: second_unit = 12
  integer, parameter                     :: time_series_unit = 20
  integer, parameter                     :: time_average_unit = 21
!-----------------------------------------------------------------
  integer, parameter                     :: ncl_info_unit = 30
  integer, parameter                     :: grads_ctl_unit = 50
  integer, parameter                     :: out_dat_unit = 60
!-----------------------------------------------------------------
  character (len=512)                    :: profile_time_series_3d
  character (len=512)                    :: profile_time_average_3d
  character (len=512)                    :: time_series_2d
  character (len=512)                    :: time_average_2d
  character (len=50)                     :: filename
!-----------------------------------------------------------------
  integer                                :: stime(6), etime(6)
  character (len=4)                      :: year
  character (len=2)                      :: month, day, hour
  character (len=19)                     :: hstart, hend, hdate
  character (len=10)                     :: date,pdate
!-----------------------------------------------------------------
  character(len=50)                      :: desc3d(max_3d_variables)
  character(len=50)                      :: desc2d(max_2d_variables)
!-----------------------------------------------------------------
  character (len=30)                     :: var_to_get, var_to_plot
  integer                                :: length_var, length_plot
!-----------------------------------------------------------------
  logical                                :: output_input_grid, use_lowest_heights
  real, dimension( num_vert_levels )     :: vert_args
  integer                                :: nx, ny, nz, number_of_levels
!-----------------------------------------------------------------
  integer                                :: io_status
!-----------------------------------------------------------------
  logical                                :: debug1, debug2
!
  logical                                :: verify_its_own_analysis
  integer                                :: num_verifying_experiments
  integer                                :: verify_forecast_hour
  integer                                :: domain
  character (len=512)                    :: control_exp_dir
  character (len=512), dimension (max_num_exps) :: verif_dirs
  character (len=512), dimension (max_num_exps) :: out_dirs
  integer                                :: start_year, end_year
  integer                                :: start_month, end_month
  integer                                :: start_day, end_day
  integer                                :: start_hour, end_hour
  integer                                :: start_minutes=0, end_minutes=0
  integer                                :: start_seconds=0, end_seconds=0
  integer                                :: interval_hour
  integer                                :: num3dvar
  integer                                :: num2dvar
  character(len=20)                      :: var3d(max_3d_variables)
  character(len=20)                      :: var2d(max_2d_variables)
  integer                                :: num_scores
  character(len=20)                      :: score_names(max_num_scores)
  character (len=1)                      :: vertical_type
  character (len=20)                     :: verification_file_string
!-----------------------------------------------------------------

  namelist /control_main/ verify_its_own_analysis, num_verifying_experiments, &
                verification_file_string,control_exp_dir,verif_dirs, out_dirs, &
                verify_forecast_hour, domain, vertical_type
  namelist /control_times/ start_year, start_month, start_day, start_hour, &
                end_year, end_month, end_day, end_hour, interval_hour
  namelist /control_vars/ num3dvar, var3d, num2dvar, var2d

end module da_verif_anal_control