*dk,recvr20
      subroutine recvr20(it1,it2,ictrecvr,ipiitmp,
     *                   ipjjtmp,ipkttmp)
       implicit real*8 (a-h,o-z)
C ######################################################################
C
C     PURPOSE -
C
C        This routine performs a temporary 2-to-0 flip and saves
C        information for later recovering the original state of the
C        mesh.  The fluxer is not called.
C
C
C     INPUT ARGUMENTS -
C
C        it1      - the first tetrahedron
C        it2      - the second tetrahedron
C**JM    ipirecvr - pointer to an array in which to store ijtet
C**JM               information for later recovering the original mesh.
C        ictrecvr - the current number of tetrahedra in the "recvr"
C                   array.
C        ipiitmp  - pointer to array to store itet information for
C                   later recovering the original mesh.
C        ipjjtmp  - pointer to array to store jtet information for
C                   later recovering the original mesh.
C        ipkttmp  - pointer to array to store tet numbers for
C                   later recovering the original mesh.
C
C     OUTPUT ARGUMENTS -
C
C        ictrecvr - the current number of tetrahedra in the "recvr"
C                   array.
C
C     CHANGE HISTORY -
C
C        $Log: recvr20.f,v $
C        Revision 2.00  2007/11/09 20:04:00  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.5   05 Jan 2001 12:57:18   dcg
CPVCS    use dble in place of float so as not to lose digits
CPVCS
CPVCS       Rev 1.4   Mon Apr 14 16:58:40 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.3   12/02/94 15:06:42   het
CPVCS    Added an option for the "cmo" access functions
CPVCS
CPVCS
CPVCS       Rev 1.2   12/01/94 18:49:02   het
CPVCS    Added a data type to the "cmo" calles
CPVCS       and added the "cmo.h" include file.
CPVCS
CPVCS       Rev 1.1   11/17/94 21:54:42   het
CPVCS    Added include files for chydro, neibor, cmerge, comdict. Added calles and
CPVCS    pointer statements for current_mesh_object database access.
CPVCS
CPVCS       Rev 1.0   11/10/94 12:17:40   pvcs
CPVCS    Original version.
C
C ######################################################################
C
      include "cmo.h"
      include "chydro.h"
      include "neibor.h"
C
C ######################################################################
C
      pointer (ipiitmp , iitmp(4,1))
      pointer (ipjjtmp , jjtmp(4,1))
      pointer (ipkttmp , kttmp(1)  )
C
C ######################################################################
C
C     DEFINE THE STATEMENT FUNCTIONS NEEDED TO CALCULATE TET VOLUMES.
C
      crosx1(i,j,k)=(yic(j)-yic(i))*(zic(k)-zic(i))-
     *              (yic(k)-yic(i))*(zic(j)-zic(i))
      crosy1(i,j,k)=(xic(k)-xic(i))*(zic(j)-zic(i))-
     *              (xic(j)-xic(i))*(zic(k)-zic(i))
      crosz1(i,j,k)=(xic(j)-xic(i))*(yic(k)-yic(i))-
     *              (xic(k)-xic(i))*(yic(j)-yic(i))
      volume(i1,i2,i3,i4)=(xic(i4)-xic(i1))*crosx1(i1,i2,i3)+
     *                    (yic(i4)-yic(i1))*crosy1(i1,i2,i3)+
     *                    (zic(i4)-zic(i1))*crosz1(i1,i2,i3)
C
C ######################################################################
C
C
C     ******************************************************************
C     FETCH MESH OBJECT NAME AND POINTER INFORMATION.
C
      if(icmoget.eq.1) then
C
      call cmo_get_name(cmo,ierror)
C
      call cmo_get_info('mbndry',cmo,mbndry,length,icmotype,ierror)
      call cmo_get_info('imt1',cmo,ipimt1,lenimt1,icmotype,ierror)
      call cmo_get_info('xic',cmo,ipxic,lenxic,icmotype,ierror)
      call cmo_get_info('yic',cmo,ipyic,lenyic,icmotype,ierror)
      call cmo_get_info('zic',cmo,ipzic,lenzic,icmotype,ierror)
      call cmo_get_info('itetclr',cmo,ipitetclr,lenitetclr,icmotype,ier)
      call cmo_get_info('itet',cmo,ipitet,lenitet,icmotype,ierror)
      call cmo_get_info('jtet',cmo,ipjtet,lenjtet,icmotype,ierror)
C
      endif
C
C     ******************************************************************
C     MAKE THE "jtet" ARRAY CONSISTENT.
C
      do 20 i=1,4
         if(0.25*dble(jtet(i,it1))+0.9.ne.it2) then
            do 10 j=1,4
               if(itet(j,it2).eq.itet(i,it1)) then
                  jtemp=jtet(j,it2)
                  itemp=jtet(i,it1)
                  jpack=jtemp
                  ipack=itemp
                  if (jtemp.lt.mbndry.and.itemp.lt.mbndry) then
                     iti=0.25*dble(itemp)+0.9
                     itj=0.25*dble(jtemp)+0.9
                     if (kfix(2,iti) .eq. 0) then
                        kfix(2,iti)=1
                        ictrecvr=ictrecvr+1
                        kttmp(ictrecvr)=iti
                        iitmp(1,ictrecvr)=itet(1,iti)
                        iitmp(2,ictrecvr)=itet(2,iti)
                        iitmp(3,ictrecvr)=itet(3,iti)
                        iitmp(4,ictrecvr)=itet(4,iti)
                        jjtmp(1,ictrecvr)=jtet(1,iti)
                        jjtmp(2,ictrecvr)=jtet(2,iti)
                        jjtmp(3,ictrecvr)=jtet(3,iti)
                        jjtmp(4,ictrecvr)=jtet(4,iti)
                     endif
                     if (kfix(2,itj) .eq. 0) then
                        kfix(2,itj)=1
                        ictrecvr=ictrecvr+1
                        kttmp(ictrecvr)=itj
                        iitmp(1,ictrecvr)=itet(1,itj)
                        iitmp(2,ictrecvr)=itet(2,itj)
                        iitmp(3,ictrecvr)=itet(3,itj)
                        iitmp(4,ictrecvr)=itet(4,itj)
                        jjtmp(1,ictrecvr)=jtet(1,itj)
                        jjtmp(2,ictrecvr)=jtet(2,itj)
                        jjtmp(3,ictrecvr)=jtet(3,itj)
                        jjtmp(4,ictrecvr)=jtet(4,itj)
                     endif
                     jtet1(jtemp)=ipack
                     jtet1(itemp)=jpack
                     goto 20
                  endif
                  if (jtemp .gt. mbndry) jtemp=jtemp-mbndry
                  if (itemp .gt. mbndry) itemp=itemp-mbndry
                  if (jtemp.lt.mbndry .and. itemp.lt.mbndry) then
                     if (imt1(itet1(jtemp)).eq.imt1(itet1(itemp))) then
                        if (jpack .gt. mbndry) jpack=jpack-mbndry
                        if (ipack .gt. mbndry) ipack=ipack-mbndry
                     else
                        if (jpack .lt. mbndry) jpack=jpack+mbndry
                        if (ipack .lt. mbndry) ipack=ipack+mbndry
                     endif
                     iti=0.25*dble(itemp)+0.9
                     itj=0.25*dble(jtemp)+0.9
                     if (kfix(2,iti) .eq. 0) then
                        kfix(2,iti)=1
                        ictrecvr=ictrecvr+1
                        kttmp(ictrecvr)=iti
                        iitmp(1,ictrecvr)=itet(1,iti)
                        iitmp(2,ictrecvr)=itet(2,iti)
                        iitmp(3,ictrecvr)=itet(3,iti)
                        iitmp(4,ictrecvr)=itet(4,iti)
                        jjtmp(1,ictrecvr)=jtet(1,iti)
                        jjtmp(2,ictrecvr)=jtet(2,iti)
                        jjtmp(3,ictrecvr)=jtet(3,iti)
                        jjtmp(4,ictrecvr)=jtet(4,iti)
                     endif
                     if (kfix(2,itj) .eq. 0) then
                        kfix(2,itj)=1
                        ictrecvr=ictrecvr+1
                        kttmp(ictrecvr)=itj
                        iitmp(1,ictrecvr)=itet(1,itj)
                        iitmp(2,ictrecvr)=itet(2,itj)
                        iitmp(3,ictrecvr)=itet(3,itj)
                        iitmp(4,ictrecvr)=itet(4,itj)
                        jjtmp(1,ictrecvr)=jtet(1,itj)
                        jjtmp(2,ictrecvr)=jtet(2,itj)
                        jjtmp(3,ictrecvr)=jtet(3,itj)
                        jjtmp(4,ictrecvr)=jtet(4,itj)
                     endif
                     jtet1(jtemp)=ipack
                     jtet1(itemp)=jpack
                  else
                     if (jtemp .lt. mbndry) then
                        itj=0.25*dble(jtemp)+0.9
                        if (kfix(2,itj) .eq. 0) then
                           kfix(2,itj)=1
                           ictrecvr=ictrecvr+1
                           kttmp(ictrecvr)=itj
                           iitmp(1,ictrecvr)=itet(1,itj)
                           iitmp(2,ictrecvr)=itet(2,itj)
                           iitmp(3,ictrecvr)=itet(3,itj)
                           iitmp(4,ictrecvr)=itet(4,itj)
                           jjtmp(1,ictrecvr)=jtet(1,itj)
                           jjtmp(2,ictrecvr)=jtet(2,itj)
                           jjtmp(3,ictrecvr)=jtet(3,itj)
                           jjtmp(4,ictrecvr)=jtet(4,itj)
                        endif
                        jtet1(jtemp)=ipack
                     endif
                     if (itemp .lt. mbndry) then
                        iti=0.25*dble(itemp)+0.9
                        if (kfix(2,iti) .eq. 0) then
                           kfix(2,iti)=1
                           ictrecvr=ictrecvr+1
                           kttmp(ictrecvr)=iti
                           iitmp(1,ictrecvr)=itet(1,iti)
                           iitmp(2,ictrecvr)=itet(2,iti)
                           iitmp(3,ictrecvr)=itet(3,iti)
                           iitmp(4,ictrecvr)=itet(4,iti)
                           jjtmp(1,ictrecvr)=jtet(1,iti)
                           jjtmp(2,ictrecvr)=jtet(2,iti)
                           jjtmp(3,ictrecvr)=jtet(3,iti)
                           jjtmp(4,ictrecvr)=jtet(4,iti)
                        endif
                        jtet1(itemp)=jpack
                     endif
                  endif
               endif
 10         continue
         endif
 20   continue
      if (kfix(2,it1) .eq. 0) then
         kfix(2,it1)=1
         ictrecvr=ictrecvr+1
         kttmp(ictrecvr)=it1
         iitmp(1,ictrecvr)=itet(1,it1)
         iitmp(2,ictrecvr)=itet(2,it1)
         iitmp(3,ictrecvr)=itet(3,it1)
         iitmp(4,ictrecvr)=itet(4,it1)
         jjtmp(1,ictrecvr)=jtet(1,it1)
         jjtmp(2,ictrecvr)=jtet(2,it1)
         jjtmp(3,ictrecvr)=jtet(3,it1)
         jjtmp(4,ictrecvr)=jtet(4,it1)
      endif
      if (kfix(2,it2) .eq. 0) then
         kfix(2,it2)=1
         ictrecvr=ictrecvr+1
         kttmp(ictrecvr)=it2
         iitmp(1,ictrecvr)=itet(1,it2)
         iitmp(2,ictrecvr)=itet(2,it2)
         iitmp(3,ictrecvr)=itet(3,it2)
         iitmp(4,ictrecvr)=itet(4,it2)
         jjtmp(1,ictrecvr)=jtet(1,it2)
         jjtmp(2,ictrecvr)=jtet(2,it2)
         jjtmp(3,ictrecvr)=jtet(3,it2)
         jjtmp(4,ictrecvr)=jtet(4,it2)
      endif
      itet(1,it1)=-itet(1,it1)
      itet(1,it2)=-itet(1,it2)
      do 30 i=1,4
 30   continue
C
      goto 9999
 9999 continue
      return
      end


      subroutine gradctr(iflg)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
C***********************************************************************
CD1
CD1  PURPOSE
CD1
CD1  This subroutine manages initization and boundary conditions
CD1  that involve gradients
CD1
C***********************************************************************
CD2
CD2 REVISION HISTORY
CD2
CD2 Initial implementation: 19-APR-02, Programmer: George Zyvoloski
CD2
CD2 $Log:   /pvcs.config/fehm90/src/gradctr.f_a  $
CD2
!D2
!D2    Rev 2.5   06 Jan 2004 10:43:12   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:07:20   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
CD2
C***********************************************************************
CD3
CD3  REQUIREMENTS TRACEABILITY
CD3
CD3 2.6 Provide Input/Output Data Files
CD3 3.0 INPUT AND OUTPUT REQUIREMENTS
CD3
C***********************************************************************
CD4
CD4  SPECIAL COMMENTS AND REFERENCES
CD4
CD4 Requirements from SDN: 10086-RD-2.20-00
CD4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
CD4   FEHM Application Version 2.20
CD4
**********************************************************************

      use comai
      use combi
      use comco2
      use comdi
      use comdti
      use comfi
      use commeth
      implicit none

      integer iflg,icode, izone, inode, idir, iroot,neq_total
      integer mi,neqp1,i,i1,i2,j,jj,ja,ngrad_max,i_2nd
      integer open_file,igradm, imodel, jk, node_second_0
c gaz 052019
      integer, allocatable ::  izonef_tmp(:)
      character*80 gradm_name
      character*5 dgradm
      character*80 gradmod_root
      logical grad_dum
      character*3 grad_all
      parameter(ngrad_max= 50)
      real*8 dist,var_inode

c================================================================
      if(igrad.eq.0) return
c================================================================
      if(iflg.eq.0) then
c
c read input
c cordg : reference coordinate
c idirg : gradient coordinate direction (1 = x,2 = y, 3 = z)
c igradf=1 : initial pressure is a variable
c igradf=2 : initial temperature is a variable
c igradf=3 : initial saturation  is a variable
c igradf=4 : specified pressure (or head) is a variable
c igradf=5 : specified inflow temperture (or enthalpy) is a variable
c xg1 is x coordinate at reference point
c yg1 is y coordinate at reference point
c zg1 is z coordinate at reference point
c var0 is variable at cordg
c grad1 is the linear gradient
c
         if(.not.allocated(izone_grad)) then
            allocate(izone_grad(ngrad_max))
            allocate(igradf(ngrad_max))
            allocate(cordg(ngrad_max))
            allocate(var0(ngrad_max))
            allocate(grad1(ngrad_max))
            allocate(idirg(ngrad_max))
            allocate(gradmod_filename(ngrad_max))
            allocate(igradmodnamlen(ngrad_max))
            allocate(igradmodelfile(ngrad_max))
            igradmd = 0
            gradmod_filename = ''
         end if
         iroot = 8
         gradmod_root(1:8)='gradtemp'
         read(inpt,*) ngrad
        do i = 1,ngrad
         grad_dum = .false.
         read(inpt,'(a80)') wdd1
          do jj = 1,78
           if(wdd1(jj:jj+2).eq.'all') grad_dum = .true.
          enddo
         backspace inpt
         if(grad_dum) then
          read(inpt,*)
     &        grad_all,cordg(i),idirg(i),
     &        igradf(i),var0(i),grad1(i)
          izone_grad(i) = -1
         else
          read(inpt,*)
     &        izone_grad(i),cordg(i),idirg(i),
     &        igradf(i),var0(i),grad1(i)
          if(izone_grad(i).ne.-1) then
           izone_grad(i) = abs(izone_grad(i))
          endif
         endif
        enddo
c
c     save zone file and parameters
c
         gradm_name = ''
         igradmd = igradmd + 1
         idgradmc = 10000+igradmd
         write(dgradm,'(i5)')idgradmc
         gradm_name(1:iroot) = gradmod_root(1:iroot)
         gradm_name(iroot+1:iroot+1) ='.'
         gradm_name(iroot+2:iroot+5) = dgradm(2:5)
         gradm_name(iroot+6:iroot+11) = '.gradf'
         gradmod_filename(igradmd)(1:iroot+11)
     &   = gradm_name(1:iroot+11)
         igradmodnamlen(igradmd)= iroot+11
c
c complete name here
c
         igradmodelfile(igradmd) = open_file(gradm_name, 'unknown')
         j = igradmodelfile(igradmd)
         write(j,'(a4, 1x, i9)') 'grad',ngrad
         do i = 1, ngrad
            write(j,*)
     &           izone_grad(i),cordg(i),idirg(i),
     &           igradf(i),var0(i),grad1(i)
         enddo
         write(j,'(a4)') 'end '
         write(j,'(8(1x,i9))') (izonef(i),i=1,n0)
         close (j)
      else if(iflg.eq.1) then
c
c modify initial values and BC's
c
        do jj = 1,igradmd
c
c read gradient info from auxillary files
c and zone list for that request
c
         j = igradmodelfile(jj)
         i1=igradmodnamlen(jj)
         j = open_file (gradmod_filename(jj), 'old')
c         open(j,file=gradmod_filename(jj)(1:i1),
c     &    status ='unknown')

         read(j,*)dgradm(1:4) ,ngrad
         do i = 1, ngrad
            read(j,*)
     &           izone_grad(i),cordg(i),idirg(i),
     &           igradf(i),var0(i),grad1(i)
         enddo
c gaz 052019
         if(.not.allocated(izonef_tmp)) allocate(izonef_tmp(n0))
         read(j,'(a4)') dgradm(1:4)
         read(j,*) (izonef_tmp(i),i=1,n0)
c
         if(iread.le.0) then
c code with no restart file is present
          if(gdpm_flag.ge.3.and.gdpm_flag.le.6) then
           neq_total = neq_primary
          else
           neq_total = neq
          endif
            do izone=1,ngrad
               do inode=1,neq_total
                  if(izonef_tmp(inode).eq.izone_grad(izone)
     &                  .or.izone_grad(izone).eq.-1) then
                     idir = idirg(izone)
                     dist = cord(inode,idir)-cordg(izone)
                     if(igradf(izone).eq.1) then
                        pho(inode)=var0(izone) + grad1(izone)*dist
                     else if(igradf(izone).eq.2) then
                        to(inode)=var0(izone) + grad1(izone)*dist
                     else if(igradf(izone).eq.3) then
                        so(inode)=var0(izone) + grad1(izone)*dist
                     else if(igradf(izone).eq.4) then
                        pflow(inode)=var0(izone) + grad1(izone)*dist
                     else if(igradf(izone).eq.5) then
                        esk(inode)=var0(izone) + grad1(izone)*dist
                     else if(igradf(izone).eq.-5) then
                        esk(inode)=-(var0(izone) + grad1(izone)*dist)
                     else if(igradf(izone).eq.6) then
                        phometh(inode)=var0(izone) + grad1(izone)*dist
                     else if(igradf(izone).eq.7) then
                        pflowmeth(inode)=var0(izone) + grad1(izone)*dist
                     else if(igradf(izone).eq.8) then
                        qflux(inode)=var0(izone) + grad1(izone)*dist
c RJP 04/10/07 added the following part for CO2
                     else if(igradf(izone).eq.9) then
                        phoco2(inode)=var0(izone) + grad1(izone)*dist
                     else if(igradf(izone).eq.10) then
                        pflowco2(inode)=var0(izone) + grad1(izone)*dist
                     endif
                  endif
               enddo
c  calculate variables from gradients for gdpm and gdkm
             if(gdpm_flag.ge.3.and.gdpm_flag.le.6) then
               do inode=1,neq_primary
                 imodel = igdpm(inode)
                 if(ngdpm_layers(imodel).ne.0) then
                  if(izonef_tmp(inode).eq.izone_grad(izone))then
c notice that the gdpm nodes are 1D
                   node_second_0 = nelm(nelm(inode+1))
                   do jk = 1, ngdpm_layers(imodel)
                     i_2nd = node_second_0 + (jk-1)
                     idir = idirg(izone)
                     dist =  cord(inode,1) - cord(i_2nd,1)
                     if(igradf(izone).eq.11) then
                        var_inode = pho(inode)
                        pho(i_2nd) = var_inode + grad1(izone)*dist
                     else if(igradf(izone).eq.12) then
                        var_inode = to(inode)
                        to(i_2nd)= var_inode + grad1(izone)*dist
                     endif
                   enddo
                   endif
                  endif
               enddo
             endif
            enddo
         else
            do izone=1,ngrad
               do inode=1,n0
                  if(izonef_tmp(inode).eq.izone_grad(izone)) then
                     idir = idirg(izone)
                     dist = cord(inode,idir)-cordg(izone)
                     if(igradf(izone).eq.4) then
                        pflow(inode)=var0(izone) + grad1(izone)*dist
                     else if(igradf(izone).eq.5) then
                        esk(inode)=var0(izone) + grad1(izone)*dist
                     else if(igradf(izone).eq.-5) then
                        esk(inode)=-(var0(izone) + grad1(izone)*dist)
                     else if(igradf(izone).eq.7) then
                        pflowmeth(inode)=var0(izone) + grad1(izone)*dist
                     else if(igradf(izone).eq.8) then
                        qflux(inode)=var0(izone) + grad1(izone)*dist
c RJP 04/10/07 added following for CO2
                     else if(igradf(izone).eq.10) then
                        pflowco2(inode)=var0(izone) + grad1(izone)*dist
                     endif
                  endif
               enddo
            enddo
         endif
c        rewind j
c        write(j,*) 'gradctr file ', jj, ' read'
        close(j, status = 'delete')
       enddo
         if(allocated(izone_grad)) then
            deallocate(izone_grad)
            deallocate(izonef_tmp)
            deallocate(igradf)
            deallocate(var0)
            deallocate(grad1)
            deallocate(cordg)
            deallocate(idirg)
            deallocate(gradmod_filename)
            deallocate(igradmodnamlen)
            deallocate(igradmodelfile)
         end if

      else if(iflg.eq.2) then
c

      else if(iflg.eq.3) then
c

      endif
c
      return
      end


! 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 ps_rand_local

use      types_mod, only : r8, PI
use  utilities_mod, only : get_unit, error_handler, E_ERR
use random_seq_mod, only : random_seq_type, init_random_seq, random_uniform
use   location_mod, only : VERTISSURFACE

implicit none

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

integer  :: num_sets, level, num, num_done, iunit
real(r8) :: err_var, bot_lat, top_lat, bot_lon, top_lon
type(random_seq_type) :: r

! Initialize the random sequence
call init_random_seq(r)

! Set up constants
num_sets =  1
level    = -1

! Open an output file and write header info
iunit = get_unit()
open(unit = iunit, file = 'ps_rand.out')

write(*, *) 'input the number of observations'
read(*, *) num

write(*, *) 'input the obs error variance'
read(*, *) err_var

write(*, *) 'input a lower bound on latitude -90 to 90'
read(*, *) bot_lat
write(*, *) 'input an upper bound on latitude -90 to 90'
read(*, *) top_lat
write(*, *) 'input a lower bound on longitude: no wraparounds for now '
read(*, *) bot_lon
write(*, *) 'input an upper bound on longitude '
read(*, *) top_lon

! Simple error check to let people know limits
if(top_lat <= bot_lat .or. top_lon <= bot_lon) then
   call error_handler(E_ERR,'ps_rand_local', 'lat lon range error', source, revision, revdate)
endif

! Input number of obs
write(iunit, *) num
! No obs values or qc
write(iunit, *) 0
write(iunit, *) 0

num_done = 0
do while(num_done < num)
   ! There are more obs
   write(iunit, *) 0

   ! Kind is ps
   write(iunit, *) 'RADIOSONDE_SURFACE_PRESSURE'

   ! Put this on model level -1
   write(iunit, *) VERTISSURFACE
   write(iunit, *) level

   ! Want randomly located in horizontal
   write(iunit, *) -1

   ! Input longitude and latitude bounds
   write(iunit, *) bot_lon
   write(iunit, *) top_lon
   write(iunit, *) bot_lat
   write(iunit, *) top_lat

   ! Time is 0 days and 0 seconds for create_obs_sequence base
   write(iunit, *) 0, 0

   ! Error variance
   write(iunit, *) err_var

   num_done = num_done + 1

end do

! File name default is set_def.out
write(iunit, *) 'set_def.out'

end program ps_rand_local

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


      subroutine bar(x,y,h,w,sh,ihat,np1)
C   subroutine     bar       01/09/78
      common/gftab/irdb(5),rdb(17)
      if(irdb(2).ne.2) goto 9
      ak=w
      call tmf(x,y,xn,yn)
      call move(xn,yn,0)
      x1=x
      y1=y+h
      call tmf(x1,y1,xn1,yn1)
      call move(xn1,yn1,1)
      x1=x1+ak
      call tmf(x1,y1,xn1,yn1)
      call move(xn1,yn1,1)
      x1=x +ak
      y1=y
      call tmf(x1,y1,xn1,yn1)
      call move(xn1,yn1,1)
      call tmf(x,y,xn,yn)
      call move(xn,yn,1)
C     set flags accoding to ihat
      if (sh.le.0) goto 9
      k1=0
      k2=0
      if(ihat-1)9,15,8
  8   if(ihat-3)11,16,13
 11   k1=1
      go to 15
 13   k1=1
 16   k2=1
C     hatch one
  15  x2=x
      y2=y+sh
      x3=x2+ak
      y3=y2
      call tmf(x3,y3,xn3,yn3)
      call move(xn3,yn3,k1)
      call tmf(x2,y2,xn2,yn2)
      call move(xn2,yn2,1)
      call tmf(x1,y1,xn1,yn1)
      call move(xn1,yn1,k2)
      if (ihat.le.1) goto 9
      fnp1=np1
      l=w*fnp1
      m=sh*fnp1
      if(m.le.0) goto 9
      if(l.le.0) goto 9
      if(l.gt.m) goto 41
      f=l
      go to 42
   41 f=m
  42  dh=sh/f
      dw=w/f
      w2=0.0
      h1=0.0
      ih=f-1.0
      do 50 i=1,ih
      h1=h1+dh
      h2=sh-h1
      w2=w2+dw
      w1=w-w2
      xp1=x+w1
      yp1=y
      xp2=x
      yp2=y+h2
      xp3=x2+w2
      yp3=y2
      xp4=x1
      yp4=y1+h1
      call tmf(xp1,yp1,xpn1,ypn1)
      call move(xpn1,ypn1,0)
      call tmf(xp2,yp2,xpn2,ypn2)
      call move(xpn2,ypn2,k2)
      call tmf(xp3,yp3,xpn3,ypn3)
      call move(xpn3,ypn3,k1)
      call tmf(xp4,yp4,xpn4,ypn4)
      call move(xpn4,ypn4,k2)
      call tmf(xp1,yp1,xpn1,ypn1)
      call move(xpn1,ypn1,k1)
  50  continue
 9    return
      end


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%!
!                    ________  ______                                  !
!                   |        ||      \                                 !
!                   `--.  .--'|  ,-.  \________  ___                   !
!                      |  |___|  |_/  /  _  \  \/  /                   !
!                      |  |___|      /  _____\    /                    !
!                      |  |   |  |\  \  \____/    \                    !
!                      |__|   |__| \__\_____/__/\__\                   !
!                                                                      !
!                                                                      !
!           BLOCK-STRUCTURED 3D HEXAHEDRAL MESH GENERATOR              !
!                                +                                     !
!                  UNSTRUCTURED CELL REFINEMENT                        !
!                                                                      !
!----------------------------------------------------------------------!
!                                                                      !
!                                     Bojan Niceno                     !
!                                     Delft University of Technology   !
!                                     Section Heat Transfer            !
!                                     niceno@duttwta.wt.tn.tudelft.nl  !
!                                                                      !
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%!
!                                                                      !
!  Block structure:                                                    !
!                                                                      !
!                               b6                                     !
!                               |                                      !
!                         8-----|---------6                            !
!                        /|     |        /|                            !
!                       / |     +   b3  / |                            !
!                      /  |        /   /  |                            !
!                     7---------------5   |                            !
!                     |   |     |/    |   |                            !
!              b4---- | +-------o-----| +-------b2                     !
!                     |   |    /|     |   |                            !
!                     |   4---/-|-----|---2                            !
!                     |  /   /  |     |  /                             !
!                     | /   b5  +     | /                              !
!                     |/              |/                               !
!                     3---------------1                                !
!                               |                                      !
!                               b1                                     !
!  Faces are defined as:
!
!     I   :
!     II  :
!     III :
!     IV  :
!     V   :
!     VI  :
!
!  Local coordinate directions:                                        !
!                                                                      !
!     i: 1 -> 2                                                        !
!     j: 1 -> 3                                                        !
!     k: 1 -> 5                                                        !
!                                                                      !
!  Notes:                                                              !
!                                                                      !
!    - can't handle domains with less then 3x3x3 cells properly        !
!    - nodes of a cell (and block) are deonoted with numbers 1 - 8     !
!    - neighbouring cells are denoted with c1 - c6                     !
!    - local coordinare directions (for blocks) are defined with:      !
!                                                                      !
!======================================================================!
  PROGRAM Generator
!----------------------------------------------------------------------!
!   Block structured mesh generation and unstructured cell refinement. *
!----------------------------------------------------------------------!
!------------------------------[Modules]-------------------------------!
  USE all_mod
  USE gen_mod
!----------------------------------------------------------------------!
  IMPLICIT NONE
!-------------------------------[Locals]-------------------------------!
  INTEGER :: c,s,n
!--------------------------------[CVS]---------------------------------!
!  $Id: Generator.f90,v 1.20 2002/10/30 16:29:21 niceno Exp $
!  $Source: /home/muhamed/.CVSROOT/T-Rex/Generate/Generator.f90,v $
!======================================================================!

!---- Test the precision
  open(90,FORM='UNFORMATTED',FILE='Generator.real');
  write(90) 3.1451592
  close(90)

  call logo

  call IniGen

  call GenLoa
  call Calc1
  call Fuzion
  call PeriBC
  call CopyBC

  call TopSys(.FALSE.)  ! trial run
  call Calc2(.FALSE.)
  call Smooth

  call Mark

  call TopSys(.TRUE.) ! real run
  call Calc2(.TRUE.)

!---- prepare for saving
  do n=1,NN
    NewN(n)=n
  end do
  do c=-NBC,NC
    NewC(c)=c
  end do
  do s=1,NS
    NewS(s)=s
  end do

!---- count the materials in the grid
  call CouMat

!---- save the grid
  call GenSav(0, NN, NC)            ! Save grid for postprocessing
  call GeoSav(0, NC, NS, NBC, 0, 0) ! Saved data for processing

  call TestLn(0, NN, NC, NS, NbC, 0)

!---- save the 1D probe (good for the channel flow)
  call Probe1D_nodes_gen

!---- save the 2D probe (good for the channel flow)
  call Probe2D

!---- create output for Fluent
  NewC(-NBC-1) = -NBC-1
  call CasSav(0, NN, NC, NS+NSsh) ! Save grid for postprocessing
                                  ! with Fluent
!---- make eps figures
  call EpsSav(y,z,x,Dy,Dz,'x')
  call EpsSav(z,x,y,Dz,Dx,'y')
  call EpsSav(x,y,z,Dx,Dy,'z')

  call EpsWho(NSsh)  ! Draw the domain with shadows

!---- write something on the screen
  call PrintG

  END PROGRAM Generator


!! Fixed in 6.2 build 6207. 6.1 status?
!!
!! INVALID INTERMEDIATE C CODE -- 3-ARG BESSEL_JN VERSION
!!
!! NAG Fortran 6.1 and 6.2 generates invalid C code for the following example.
!!
!! $ nagfor nag-20180203a.f90 -c
!! NAG Fortran Compiler Release 6.2(Chiyoda) Build 6205
!! [NAG Fortran Compiler normal termination]
!! nag-20180203a.f90: In function 'bar_':
!! nag-20180203a.f90:4:18: error: too many arguments to function '__NAGf90_jn_f'
!!    array = bessel_jn(1,n,x)
!!                   ^~~~~~~~~
!! In file included from /opt/nag/nagfor-6.2/lib/nagfortran.h:133:0,
!!                  from nag-20180203a.f90:1:
!! /opt/nag/nagfor-6.2/lib/libfm.h:119:19: note: declared here
!!  VPure float CDECL __NAGf90_jn_f(INT64 n,float x);

subroutine bar(n,x,array)
  integer n
  real x, array(n)
  array = bessel_jn(1,n,x)
end subroutine


module innovstats
!$$$  module documentation block
!
! module: innovstats                   print ensemble innovation statistics.
!
! prgmmr: whitaker         org: esrl/psd               date: 2009-02-23
!
! abstract:
!
! Public Subroutines:
!  print_innovstats: given obfit_prior and obsprd_prior (observation -
!   ensemble mean observation variable, ensemble standard deviation of
!   observation variable), print some statistics useful for monitoring.
!
! Public Variables: None
!
! program history log:
!   2009-02-23  Initial version.
!   2012-05-    Todling : added the Jo fits to the statistics table
!   2012-05-14  El Akkraoui : use the oberr_orig instead of oberrvar in the
!                             statistics table
!   2016-03-21  Todling - add stats for AOD
!   2017-05-20  Todling - allow calc of stats for assimilated obs only
!
! attributes:
!   language: f95
!
!$$$

use enkf_obsmod, only:  oberrvar,ob,ensmean_ob,obtype,nobs_conv,nobs_oz,&
                   nobs_sat,nobstot,obloclat,ensmean_obnobc,obpress,stattype,&
                   oberrvar_orig,indxsat,iused
use params, only : latbound,stats_usedob_only
use kinds, only: i_kind, r_kind,r_single
use radinfo, only: jpch_rad,nusis,nuchan
use constants, only: one,zero

implicit none

private

public :: print_innovstats

contains

subroutine print_innovstats(obfit,obsprd)
real(r_single), intent(in) :: obfit(nobstot), obsprd(nobstot)
integer(i_kind) nobst_nh,nobst_sh,nobst_tr,&
 nobspw_nh,nobspw_sh,nobspw_tr,&
 nobsspd_nh,nobsspd_sh,nobsspd_tr,&
 nobsgps_nh,nobsgps_sh,nobsgps_tr,&
 nobsaod_nh,nobsaod_sh,nobsaod_tr,&
 nobsq_nh,nobsq_sh,nobsq_tr,nobswnd_nh,nobswnd_sh,nobswnd_tr,&
 nobsoz_nh,nobsoz_sh,nobsoz_tr,nobsps_sh,nobsps_nh,nobsps_tr,nob, &
 nobsps_tot,nobst_tot,nobswnd_tot,nobsq_tot,nobsoz_tot,nobspw_tot,&
 nobsspd_tot,nobsgps_tot,nobsaod_tot
integer(i_kind) nobssat_tot,ntotassim
real(r_single) sumps_nh,biasps_nh,sumps_sh,biasps_sh,&
 sumps_tr,biasps_tr,&
 sumps_spread_nh,sumps_spread_sh,sumps_spread_tr,sumps_oberr_nh,&
 sumps_oberr_sh,sumps_oberr_tr,&
 sumt_nh,biast_nh,sumt_spread_nh,sumt_oberr_nh,&
 sumt_sh,biast_sh,sumt_spread_sh,sumt_oberr_sh,&
 sumt_tr,biast_tr,sumt_spread_tr,sumt_oberr_tr,&
 sumq_nh,biasq_nh,sumq_spread_nh,sumq_oberr_nh,&
 sumq_sh,biasq_sh,sumq_spread_sh,sumq_oberr_sh,&
 sumq_tr,biasq_tr,sumq_spread_tr,sumq_oberr_tr,&
 sumspd_nh,biasspd_nh,sumspd_spread_nh,sumspd_oberr_nh,&
 sumspd_sh,biasspd_sh,sumspd_spread_sh,sumspd_oberr_sh,&
 sumspd_tr,biasspd_tr,sumspd_spread_tr,sumspd_oberr_tr,&
 sumgps_nh,biasgps_nh,sumgps_spread_nh,sumgps_oberr_nh,&
 sumgps_sh,biasgps_sh,sumgps_spread_sh,sumgps_oberr_sh,&
 sumgps_tr,biasgps_tr,sumgps_spread_tr,sumgps_oberr_tr,&
 sumaod_nh,biasaod_nh,sumaod_spread_nh,sumaod_oberr_nh,&
 sumaod_sh,biasaod_sh,sumaod_spread_sh,sumaod_oberr_sh,&
 sumaod_tr,biasaod_tr,sumaod_spread_tr,sumaod_oberr_tr,&
 sumpw_nh,biaspw_nh,sumpw_spread_nh,sumpw_oberr_nh,&
 sumpw_sh,biaspw_sh,sumpw_spread_sh,sumpw_oberr_sh,&
 sumpw_tr,biaspw_tr,sumpw_spread_tr,sumpw_oberr_tr,&
 sumoz_nh,biasoz_nh,sumoz_spread_nh,sumoz_oberr_nh,&
 sumoz_sh,biasoz_sh,sumoz_spread_sh,sumoz_oberr_sh,&
 sumoz_tr,biasoz_tr,sumoz_spread_tr,sumoz_oberr_tr,&
 sumwnd_nh,biaswnd_nh,sumwnd_spread_nh,sumwnd_oberr_nh,&
 sumwnd_sh,biaswnd_sh,sumwnd_spread_sh,sumwnd_oberr_sh,&
 sumwnd_tr,biaswnd_tr,sumwnd_spread_tr,sumwnd_oberr_tr
real(r_single) sumpsjo_nh,sumpsjo_sh,sumpsjo_tr,sumpsjo
real(r_single) sumtjo_nh,sumtjo_sh,sumtjo_tr,sumtjo
real(r_single) sumwndjo_nh,sumwndjo_sh,sumwndjo_tr,sumwndjo
real(r_single) sumqjo_nh,sumqjo_sh,sumqjo_tr,sumqjo
real(r_single) sumspdjo_nh,sumspdjo_sh,sumspdjo_tr,sumspdjo
real(r_single) sumgpsjo_nh,sumgpsjo_sh,sumgpsjo_tr,sumgpsjo
real(r_single) sumaodjo_nh,sumaodjo_sh,sumaodjo_tr,sumaodjo
real(r_single) sumpwjo_nh,sumpwjo_sh,sumpwjo_tr,sumpwjo
real(r_single) sumozjo_nh,sumozjo_sh,sumozjo_tr,sumozjo
real(r_single) sumjo_tot
! stuff for computing sat data innovation stats.
real(r_single) sumsprd_sat(jpch_rad),sumerr_sat(jpch_rad), &
     sumfit_sat(jpch_rad),sumfitsq_sat(jpch_rad),sumjo_sat(jpch_rad),&
     predicted_innov,innov
integer(i_kind) nob_sat(jpch_rad),nchan,nn
real(r_single) :: denom
!==> stats for conventional + ozone obs.
  !==> pre-process obs, obs metadata.
  nobsps_nh = 0
  nobsps_sh = 0
  nobsps_tr = 0
  nobsps_tot= 0
  nobst_nh = 0
  nobst_sh = 0
  nobst_tr = 0
  nobst_tot=0
  nobsq_nh = 0
  nobsq_sh = 0
  nobsq_tr = 0
  nobsq_tot=0
  nobsoz_nh = 0
  nobsoz_sh = 0
  nobsoz_tr = 0
  nobsoz_tot=0
  nobswnd_nh = 0
  nobswnd_sh = 0
  nobswnd_tr = 0
  nobswnd_tot=0
  nobspw_nh = 0
  nobspw_sh = 0
  nobspw_tr = 0
  nobspw_tot=0
  nobsgps_nh = 0
  nobsgps_sh = 0
  nobsgps_tr = 0
  nobsgps_tot=0
  nobsaod_nh = 0
  nobsaod_sh = 0
  nobsaod_tr = 0
  nobsaod_tot=0
  nobsspd_nh = 0
  nobsspd_sh = 0
  nobsspd_tr = 0
  nobsspd_tot=0
  nobssat_tot=0
  ntotassim=0
  sumpsjo =0.0
  sumtjo  =0.0
  sumwndjo=0.0
  sumqjo  =0.0
  sumspdjo=0.0
  sumpwjo =0.0
  sumgpsjo=0.0
  sumaodjo=0.0
  sumozjo =0.0
  sumjo_tot=0.0
  sumps_nh =0.0;sumps_tr =0.0;sumps_sh =0.0
  sumq_nh  =0.0;sumq_tr  =0.0;sumq_sh  =0.0
  sumt_nh  =0.0;sumt_tr  =0.0;sumt_sh  =0.0
  sumpw_nh =0.0;sumpw_tr =0.0;sumpw_sh =0.0
  sumaod_nh=0.0;sumaod_tr=0.0;sumaod_sh=0.0
  sumgps_nh=0.0;sumgps_tr=0.0;sumgps_sh=0.0
  sumspd_nh=0.0;sumspd_tr=0.0;sumspd_sh=0.0
  sumwnd_nh=0.0;sumwnd_tr=0.0;sumwnd_sh=0.0
  sumoz_nh =0.0;sumoz_tr =0.0;sumoz_sh =0.0
if (nobs_conv+nobs_oz > 0) then
  do nob=1,nobs_conv+nobs_oz
     if(stats_usedob_only) then
       if(iused(nob)==0) cycle ! do not include not assim obs in statistics
     endif
     if(oberrvar(nob) < 1.e10_r_single)then
         if (obtype(nob)(1:3) == ' ps') then
             call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),&
                 obsprd(nob),obloclat(nob),&
                 sumps_nh,biasps_nh,sumps_spread_nh,sumps_oberr_nh,nobsps_nh,sumpsjo_nh,&
                 sumps_sh,biasps_sh,sumps_spread_sh,sumps_oberr_sh,nobsps_sh,sumpsjo_sh,&
                 sumps_tr,biasps_tr,sumps_spread_tr,sumps_oberr_tr,nobsps_tr,sumpsjo_tr)
            nobsps_tot = nobsps_nh + nobsps_sh + nobsps_tr
            sumpsjo = sumpsjo_nh + sumpsjo_sh + sumpsjo_tr
            ntotassim=ntotassim+1
         else if (obtype(nob)(1:3) == '  t' .and. stattype(nob) /= 121) then
             call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),&
                 obsprd(nob),obloclat(nob),&
                 sumt_nh,biast_nh,sumt_spread_nh,sumt_oberr_nh,nobst_nh,sumtjo_nh,&
                 sumt_sh,biast_sh,sumt_spread_sh,sumt_oberr_sh,nobst_sh,sumtjo_sh,&
                 sumt_tr,biast_tr,sumt_spread_tr,sumt_oberr_tr,nobst_tr,sumtjo_tr)
            nobst_tot = nobst_nh + nobst_sh + nobst_tr
            sumtjo = sumtjo_nh + sumtjo_sh + sumtjo_tr
            ntotassim=ntotassim+1
        ! all winds
         else if (obtype(nob)(1:3) == '  u' .or. obtype(nob)(1:3) == '  v') then
        ! only in-situ winds (no sat winds)
        !else if (obtype(nob)(1:3) == '  u' .or. obtype(nob)(1:3) == '  v' .and. &
        !        ((stattype(nob) >= 280 .and. stattype(nob) <= 282) .or. &
        !         (stattype(nob) >= 220 .and. stattype(nob) <= 221) .or. &
        !         (stattype(nob) >= 230 .and. stattype(nob) <= 235) ) then
             call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),&
                 obsprd(nob),obloclat(nob),&
                 sumwnd_nh,biaswnd_nh,sumwnd_spread_nh,sumwnd_oberr_nh,nobswnd_nh,sumwndjo_nh,&
                 sumwnd_sh,biaswnd_sh,sumwnd_spread_sh,sumwnd_oberr_sh,nobswnd_sh,sumwndjo_sh,&
                 sumwnd_tr,biaswnd_tr,sumwnd_spread_tr,sumwnd_oberr_tr,nobswnd_tr,sumwndjo_tr)
            nobswnd_tot = nobswnd_nh + nobswnd_sh + nobswnd_tr
            sumwndjo = sumwndjo_nh + sumwndjo_sh + sumwndjo_tr
            ntotassim=ntotassim+1
         else if (obtype(nob)(1:3) == '  q') then
             call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),&
                 obsprd(nob),obloclat(nob),&
                 sumq_nh,biasq_nh,sumq_spread_nh,sumq_oberr_nh,nobsq_nh,sumqjo_nh,&
                 sumq_sh,biasq_sh,sumq_spread_sh,sumq_oberr_sh,nobsq_sh,sumqjo_sh,&
                 sumq_tr,biasq_tr,sumq_spread_tr,sumq_oberr_tr,nobsq_tr,sumqjo_tr)
            nobsq_tot = nobsq_nh + nobsq_sh + nobsq_tr
            sumqjo = sumqjo_nh + sumqjo_sh + sumqjo_tr
            ntotassim=ntotassim+1
         else if (obtype(nob)(1:3) == 'spd') then
             call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),&
                 obsprd(nob),obloclat(nob),&
                 sumspd_nh,biasspd_nh,sumspd_spread_nh,sumspd_oberr_nh,nobsspd_nh,sumspdjo_nh,&
                 sumspd_sh,biasspd_sh,sumspd_spread_sh,sumspd_oberr_sh,nobsspd_sh,sumspdjo_sh,&
                 sumspd_tr,biasspd_tr,sumspd_spread_tr,sumspd_oberr_tr,nobsspd_tr,sumspdjo_tr)
            nobsspd_tot = nobsspd_nh + nobsspd_sh + nobsspd_tr
            sumspdjo = sumspdjo_nh + sumspdjo_sh + sumspdjo_tr
            ntotassim=ntotassim+1
         else if (obtype(nob)(1:3) == 'gps') then
             call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),&
                 obsprd(nob),obloclat(nob),&
                 sumgps_nh,biasgps_nh,sumgps_spread_nh,sumgps_oberr_nh,nobsgps_nh,sumgpsjo_nh,&
                 sumgps_sh,biasgps_sh,sumgps_spread_sh,sumgps_oberr_sh,nobsgps_sh,sumgpsjo_sh,&
                 sumgps_tr,biasgps_tr,sumgps_spread_tr,sumgps_oberr_tr,nobsgps_tr,sumgpsjo_tr)
            nobsgps_tot = nobsgps_nh + nobsgps_sh + nobsgps_tr
            sumgpsjo = sumgpsjo_nh + sumgpsjo_sh + sumgpsjo_tr
            ntotassim=ntotassim+1
         else if (obtype(nob)(1:3) == ' pw') then
             call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),&
                 obsprd(nob),obloclat(nob),&
                 sumpw_nh,biaspw_nh,sumpw_spread_nh,sumpw_oberr_nh,nobspw_nh,sumpwjo_nh,&
                 sumpw_sh,biaspw_sh,sumpw_spread_sh,sumpw_oberr_sh,nobspw_sh,sumpwjo_sh,&
                 sumpw_tr,biaspw_tr,sumpw_spread_tr,sumpw_oberr_tr,nobspw_tr,sumpwjo_tr)
            nobspw_tot = nobspw_nh + nobspw_sh + nobspw_tr
            sumpwjo = sumpwjo_nh + sumpwjo_sh + sumpwjo_tr
            ntotassim=ntotassim+1
         else if (nob > nobs_conv .and. nob < nobs_conv+nobs_oz) then
             call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),&
                 obsprd(nob),obloclat(nob),&
                 sumoz_nh,biasoz_nh,sumoz_spread_nh,sumoz_oberr_nh,nobsoz_nh,sumozjo_nh,&
                 sumoz_sh,biasoz_sh,sumoz_spread_sh,sumoz_oberr_sh,nobsoz_sh,sumozjo_sh,&
                 sumoz_tr,biasoz_tr,sumoz_spread_tr,sumoz_oberr_tr,nobsoz_tr,sumozjo_tr)
            nobsoz_tot = nobsoz_nh + nobsoz_sh + nobsoz_tr
            sumozjo= sumozjo_nh + sumozjo_sh + sumozjo_tr
            ntotassim=ntotassim+1
         end if
      end if
  end do ! loop over non-radiance obs
  do nob=nobs_conv+nobs_oz+nobs_sat+1,size(obtype)
     if(stats_usedob_only) then
       if(iused(nob)==0) cycle ! do not include not assim obs in statistics
     endif
     if(oberrvar(nob) < 1.e10_r_kind)then
         if (obtype(nob)(1:3) == 'aod') then
             call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),&
                 obsprd(nob),obloclat(nob),&
                 sumaod_nh,biasaod_nh,sumaod_spread_nh,sumaod_oberr_nh,nobsaod_nh,sumaodjo_nh,&
                 sumaod_sh,biasaod_sh,sumaod_spread_sh,sumaod_oberr_sh,nobsaod_sh,sumaodjo_sh,&
                 sumaod_tr,biasaod_tr,sumaod_spread_tr,sumaod_oberr_tr,nobsaod_tr,sumaodjo_tr)
            nobsaod_tot = nobsaod_nh + nobsaod_sh + nobsaod_tr
            sumaodjo = sumaodjo_nh + sumaodjo_sh + sumaodjo_tr
            ntotassim=ntotassim+1
         endif
     endif
  end do ! loop over aod observations
!--> print innovation statistics for subset of conventional data.
   print *,'conventional obs'
   print *,'region, obtype, nobs, bias, innov stdev, sqrt(S+R), sqrt(S), sqrt(R), Jo:'
   call printstats('   all ps',sumps_nh,biasps_nh,sumps_spread_nh,sumps_oberr_nh,sumpsjo_nh,nobsps_nh,&
        sumps_sh,biasps_sh,sumps_spread_sh,sumps_oberr_sh,sumpsjo_sh,nobsps_sh,&
        sumps_tr,biasps_tr,sumps_spread_tr,sumps_oberr_tr,sumpsjo_tr,nobsps_tr)
   call printstats('    all t',sumt_nh,biast_nh,sumt_spread_nh,sumt_oberr_nh,sumtjo_nh,nobst_nh,&
        sumt_sh,biast_sh,sumt_spread_sh,sumt_oberr_sh,sumtjo_sh,nobst_sh,&
        sumt_tr,biast_tr,sumt_spread_tr,sumt_oberr_tr,sumtjo_tr,nobst_tr)
   call printstats('   all uv',sumwnd_nh,biaswnd_nh,sumwnd_spread_nh,sumwnd_oberr_nh,sumwndjo_nh,nobswnd_nh,&
        sumwnd_sh,biaswnd_sh,sumwnd_spread_sh,sumwnd_oberr_sh,sumwndjo_sh,nobswnd_sh,&
        sumwnd_tr,biaswnd_tr,sumwnd_spread_tr,sumwnd_oberr_tr,sumwndjo_tr,nobswnd_tr)
   call printstats('    all q',sumq_nh,biasq_nh,sumq_spread_nh,sumq_oberr_nh,sumqjo_nh,nobsq_nh,&
        sumq_sh,biasq_sh,sumq_spread_sh,sumq_oberr_sh,sumqjo_sh,nobsq_sh,&
        sumq_tr,biasq_tr,sumq_spread_tr,sumq_oberr_tr,sumqjo_tr,nobsq_tr)
   call printstats('  all spd',sumspd_nh,biasspd_nh,sumspd_spread_nh,sumspd_oberr_nh,sumspdjo_nh,nobsspd_nh,&
        sumspd_sh,biasspd_sh,sumspd_spread_sh,sumspd_oberr_sh,sumspdjo_sh,nobsspd_sh,&
        sumspd_tr,biasspd_tr,sumspd_spread_tr,sumspd_oberr_tr,sumspdjo_tr,nobsspd_tr)
   call printstats('   all pw',sumpw_nh,biasq_nh,sumpw_spread_nh,sumpw_oberr_nh,sumpwjo_nh,nobspw_nh,&
        sumpw_sh,biaspw_sh,sumpw_spread_sh,sumpw_oberr_sh,sumpwjo_sh,nobspw_sh,&
        sumpw_tr,biaspw_tr,sumpw_spread_tr,sumpw_oberr_tr,sumpwjo_tr,nobspw_tr)
   call printstats('  all gps',sumgps_nh,biasq_nh,sumgps_spread_nh,sumgps_oberr_nh,sumgpsjo_nh,nobsgps_nh,&
        sumgps_sh,biasgps_sh,sumgps_spread_sh,sumgps_oberr_sh,sumgpsjo_sh,nobsgps_sh,&
        sumgps_tr,biasgps_tr,sumgps_spread_tr,sumgps_oberr_tr,sumgpsjo_tr,nobsgps_tr)
   call printstats('  all aod',sumaod_nh,biasq_nh,sumaod_spread_nh,sumaod_oberr_nh,sumaodjo_nh,nobsaod_nh,&
        sumaod_sh,biasaod_sh,sumaod_spread_sh,sumaod_oberr_sh,sumaodjo_sh,nobsaod_sh,&
        sumaod_tr,biasaod_tr,sumaod_spread_tr,sumaod_oberr_tr,sumaodjo_tr,nobsaod_tr)
   call printstats(' sbuv2 oz',sumoz_nh,biasoz_nh,sumoz_spread_nh,sumoz_oberr_nh,sumozjo_nh,nobsoz_nh,&
        sumoz_sh,biasoz_sh,sumoz_spread_sh,sumoz_oberr_sh,sumozjo_sh,nobsoz_sh,&
        sumoz_tr,biasoz_tr,sumoz_spread_tr,sumoz_oberr_tr,sumozjo_tr,nobsoz_tr)
end if ! nobs_conv+nobs_oz > 0

if (size(obtype)-(nobs_conv+nobs_oz+nobs_sat+1) > 0) then
  do nob=nobs_conv+nobs_oz+nobs_sat+1,size(obtype)
     if(stats_usedob_only) then
       if(iused(nob)==0) cycle ! do not include not assim obs in statistics
     endif
     if(oberrvar(nob) < 1.e10_r_kind)then
         if (obtype(nob)(1:3) == 'aod') then
             call obstats(obfit(nob),oberrvar(nob),oberrvar_orig(nob),&
                 obsprd(nob),obloclat(nob),&
                 sumaod_nh,biasaod_nh,sumaod_spread_nh,sumaod_oberr_nh,nobsaod_nh,sumaodjo_nh,&
                 sumaod_sh,biasaod_sh,sumaod_spread_sh,sumaod_oberr_sh,nobsaod_sh,sumaodjo_sh,&
                 sumaod_tr,biasaod_tr,sumaod_spread_tr,sumaod_oberr_tr,nobsaod_tr,sumaodjo_tr)
            nobsaod_tot = nobsaod_nh + nobsaod_sh + nobsaod_tr
            sumaodjo = sumaodjo_nh + sumaodjo_sh + sumaodjo_tr
            ntotassim=ntotassim+1
         endif
     endif
  end do ! loop over aod observations
   call printstats('  all aod',sumaod_nh,biasq_nh,sumaod_spread_nh,sumaod_oberr_nh,sumaodjo_nh,nobsaod_nh,&
        sumaod_sh,biasaod_sh,sumaod_spread_sh,sumaod_oberr_sh,sumaodjo_sh,nobsaod_sh,&
        sumaod_tr,biasaod_tr,sumaod_spread_tr,sumaod_oberr_tr,sumaodjo_tr,nobsaod_tr)
endif

sumjo_tot = sumpsjo+sumtjo+sumwndjo+sumqjo+sumspdjo+sumpwjo+sumgpsjo+sumaodjo+sumozjo
!==> stats for satellite brightness temp obs (amsua only).
  sumsprd_sat = zero
  sumfit_sat = zero
  sumerr_sat = zero
  sumfitsq_sat = zero
  sumjo_sat = zero
  nob_sat = 0
if (nobs_sat > 0) then
  nn = 0
  do nob=nobs_conv+nobs_oz+1,nobs_conv+nobs_oz+nobs_sat
     nn = nn + 1
     if(stats_usedob_only) then
       if(iused(nob)==0) cycle ! do not include not assim obs in statistics
     endif
     nchan = indxsat(nn)
     if (oberrvar(nob) < 1.e10_r_single .and. nchan > 0) then
       sumsprd_sat(nchan)=sumsprd_sat(nchan)+obsprd(nob)
       sumerr_sat(nchan)=sumerr_sat(nchan)+oberrvar_orig(nob)
       sumfitsq_sat(nchan)=sumfitsq_sat(nchan)+obfit(nob)**2
       sumfit_sat(nchan)=sumfit_sat(nchan)+obfit(nob)
       sumjo_sat(nchan)=sumjo_sat(nchan)+obfit(nob)**2/oberrvar(nob)
       nob_sat(nchan)=nob_sat(nchan) + 1
       nobssat_tot=nobssat_tot+1
       ntotassim=ntotassim+1
     end if
  end do ! loop over obs

  sumjo_tot = sumjo_tot + sum(sumjo_sat)

!--> print innovation statistics for amsu-a sat data..
  print *,'satellite brightness temp'
  print *,'instrument, channel #, nobs, bias, innov stdev, sqrt(S+R), sqrt(S), sqrt(R), Jo:'
  do nchan=1,jpch_rad
     if (nob_sat(nchan) > 0) then
       denom=one/real(nob_sat(nchan),r_single)
       sumfit_sat(nchan) = sumfit_sat(nchan)*denom
       sumfitsq_sat(nchan) = sumfitsq_sat(nchan)*denom
       sumerr_sat(nchan) = sumerr_sat(nchan)*denom
       sumsprd_sat(nchan) = sumsprd_sat(nchan)*denom
       predicted_innov = sqrt(sumsprd_sat(nchan)+sumerr_sat(nchan))
       !innov = sqrt(sumfitsq_sat(nchan)-sumfit_sat(nchan)**2)
       innov = sqrt(sumfitsq_sat(nchan))
       write(6,9805) trim(adjustl(nusis(nchan))),nuchan(nchan),nob_sat(nchan),sumfit_sat(nchan),innov,&
                  predicted_innov,sqrt(sumsprd_sat(nchan)),&
                  sqrt(sumerr_sat(nchan)),sumjo_sat(nchan)
     end if
  end do
  write(6,9805) trim(adjustl('GL all sat')), 999, 999,sum(sumfit_sat),0.,&
            0.,0.,0.,sum(sumjo_sat)
9805 format(a20,i4,1x,i5,1p,6(1x,e10.3))
end if !nobs_sat>0

write(6,9806)'Observation Type',' ','Nobs','Jo','Jo/n'
if(nobsps_tot >0) write(6,9807) "surface pressure",nobsps_tot,real(sumpsjo,r_kind),real(sumpsjo/nobsps_tot,r_kind)
if(nobst_tot  >0) write(6,9807) "temperature",nobst_tot,real(sumtjo,r_kind),real(sumtjo/nobst_tot,r_kind)
if(nobswnd_tot>0) write(6,9807) "wind",nobswnd_tot,real(sumwndjo,r_kind),real(sumwndjo/nobswnd_tot,r_kind)
if(nobsq_tot  >0) write(6,9807) "moisture",nobsq_tot,real(sumqjo,r_kind),real(sumqjo/nobsq_tot,r_kind)
if(nobspw_tot >0) write(6,9807) "precipitation",nobspw_tot,real(sumpwjo,r_kind),real(sumpwjo/nobspw_tot,r_kind)
if(nobsoz_tot >0) write(6,9807) "ozone",nobsoz_tot,real(sumozjo,r_kind),real(sumozjo/nobsoz_tot,r_kind)
if(nobsgps_tot>0) write(6,9807) "gps",nobsgps_tot,real(sumgpsjo,r_kind),real(sumgpsjo/nobsgps_tot,r_kind)
if(nobsaod_tot>0) write(6,9807) "aod",nobsaod_tot,real(sumaodjo,r_kind),real(sumaodjo/nobsaod_tot,r_kind)
if(nobssat_tot>0) write(6,9807) "radiance",nobssat_tot,real(sum(sumjo_sat),r_kind),real(sum(sumjo_sat)/nobssat_tot,r_kind)
if(ntotassim > 0) write(6,9807) "Jo Global",ntotassim,real(sumjo_tot,r_kind),&
                    real(sumjo_tot/(ntotassim),r_kind)
9806 format(a20,2x,a3,2x,a8,2x,a24,4x,a8)
9807 format(a20,2x,3x,2x,i8,2x,es24.16,2x,f10.3)

end subroutine print_innovstats

subroutine obstats(obfit,oberrjo,oberrvar,obsprd,obloclat,&
                   sumfit_nh,sumbias_nh,sumspread_nh,sumoberr_nh,nobs_nh,sumjo_nh,&
                   sumfit_sh,sumbias_sh,sumspread_sh,sumoberr_sh,nobs_sh,sumjo_sh,&
                   sumfit_tr,sumbias_tr,sumspread_tr,sumoberr_tr,nobs_tr,sumjo_tr)

  implicit none
  real(r_single), intent(in out) ::  sumfit_nh, sumbias_nh, sumspread_nh, sumoberr_nh,&
       sumfit_tr, sumbias_tr, sumspread_tr, sumoberr_tr,&
       sumfit_sh, sumbias_sh, sumspread_sh, sumoberr_sh,&
       sumjo_nh, sumjo_sh, sumjo_tr
  real(r_single), intent(in) :: obfit,oberrjo, oberrvar, obsprd, obloclat
  integer(i_kind), intent(in out) :: nobs_nh, nobs_sh, nobs_tr

! compute innovation statistics in nh,sh,tropics.

  if (obloclat > latbound) then
     if (nobs_nh == 0) then
       sumfit_nh = obfit**2
       sumbias_nh = obfit
       sumspread_nh = obsprd
       sumoberr_nh = oberrvar
       sumjo_nh = obfit**2/oberrjo
     else
       sumfit_nh = sumfit_nh + obfit**2
       sumbias_nh = sumbias_nh + obfit
       sumspread_nh = sumspread_nh + obsprd
       sumoberr_nh = sumoberr_nh + oberrvar
       sumjo_nh = sumjo_nh + obfit**2/oberrjo
     end if
     nobs_nh = nobs_nh + 1
  else if (obloclat < -latbound) then
     if (nobs_sh == 0) then
       sumfit_sh = obfit**2
       sumbias_sh = obfit
       sumspread_sh = obsprd
       sumoberr_sh = oberrvar
       sumjo_sh = obfit**2/oberrjo
     else
       sumfit_sh = sumfit_sh + obfit**2
       sumbias_sh = sumbias_sh + obfit
       sumspread_sh = sumspread_sh + obsprd
       sumoberr_sh = sumoberr_sh + oberrvar
       sumjo_sh = sumjo_sh + obfit**2/oberrjo
     end if
     nobs_sh = nobs_sh + 1
  else
     if (nobs_tr == 0) then
       sumfit_tr = obfit**2
       sumbias_tr = obfit
       sumspread_tr = obsprd
       sumoberr_tr = oberrvar
       sumjo_tr = obfit**2/oberrjo
     else
       sumfit_tr = sumfit_tr + obfit**2
       sumbias_tr = sumbias_tr + obfit
       sumspread_tr = sumspread_tr + obsprd
       sumoberr_tr = sumoberr_tr + oberrvar
       sumjo_tr = sumjo_tr + obfit**2/oberrjo
     end if
     nobs_tr = nobs_tr + 1
  end if

end subroutine obstats

subroutine printstats(obtype,sum_nh,bias_nh,sum_spread_nh,sum_oberr_nh,sum_jo_nh,nobs_nh,&
              sum_sh,bias_sh,sum_spread_sh,sum_oberr_sh,sum_jo_sh,nobs_sh,&
              sum_tr,bias_tr,sum_spread_tr,sum_oberr_tr,sum_jo_tr,nobs_tr)
  implicit none
  real(r_single), intent(in out) ::  bias_nh, sum_spread_nh, sum_oberr_nh,&
       bias_tr, sum_spread_tr, sum_oberr_tr,&
       bias_sh, sum_spread_sh, sum_oberr_sh, &
       sum_nh,sum_sh,sum_tr
  real(r_single), intent(in out) :: sum_jo_nh,sum_jo_sh,sum_jo_tr
  integer(i_kind), intent(in) :: nobs_nh, nobs_sh, nobs_tr
  character(len=9), intent(in) :: obtype
  real(r_single) :: denom
  integer(i_kind) :: ntot
  real(r_single) :: sum_tot,bias_tot,sum_oberr_tot,sum_spread_tot,sum_jo_tot

!   print *,'obtype,nobs_nh,nobs_sh,nobs_tr ',obtype,nobs_nh,nobs_sh,nobs_tr
  if (nobs_nh > 0) then
     denom=one!_RT/real(nobs_nh,r_single)
     sum_nh = sum_nh*denom
     bias_nh = bias_nh*denom
     sum_oberr_nh = sum_oberr_nh*denom
     sum_spread_nh = sum_spread_nh*denom
     write(6,9805) &
     'NH',obtype,nobs_nh,bias_nh,sqrt(sum_nh),sqrt(sum_spread_nh+sum_oberr_nh),sqrt(sum_spread_nh),sqrt(sum_oberr_nh),&
     sum_jo_nh
  end if
  if (nobs_tr > 0) then
     denom=one!_RT/real(nobs_tr,r_single)
     sum_tr = sum_tr*denom
     bias_tr = bias_tr*denom
     sum_oberr_tr = sum_oberr_tr*denom
     sum_spread_tr = sum_spread_tr*denom
     write(6,9805) &
     'TR',obtype,nobs_tr,bias_tr,sqrt(sum_tr),sqrt(sum_spread_tr+sum_oberr_tr),sqrt(sum_spread_tr),sqrt(sum_oberr_tr),&
     sum_jo_tr
  end if
  if (nobs_sh > 0) then
     denom=one!_RT/real(nobs_sh,r_single)
     sum_sh = sum_sh*denom
     bias_sh = bias_sh*denom
     sum_oberr_sh = sum_oberr_sh*denom
     sum_spread_sh = sum_spread_sh*denom
     write(6,9805) &
     'SH',obtype,nobs_sh,bias_sh,sqrt(sum_sh),sqrt(sum_spread_sh+sum_oberr_sh),sqrt(sum_spread_sh),sqrt(sum_oberr_sh),&
     sum_jo_sh
  end if
  ntot=nobs_nh+nobs_tr+nobs_sh
  if ( ntot>0 ) then
     sum_tot = (sum_nh+sum_tr+sum_sh)/ntot
     bias_tot = (bias_nh+bias_tr+bias_sh)/ntot
     sum_oberr_tot = (sum_oberr_nh+sum_oberr_tr+sum_oberr_sh)/ntot
     sum_spread_tot = (sum_spread_nh+sum_spread_tr+sum_spread_sh)/ntot
     sum_jo_tot = sum_jo_nh+sum_jo_tr+sum_jo_sh
     write(6,9805) &
     'GL',obtype,ntot,bias_tot,sqrt(sum_tot),sqrt(sum_spread_tot+sum_oberr_tot),sqrt(sum_spread_tot),sqrt(sum_oberr_tot),&
     sum_jo_tot
  end if
9805 format(a2,1x,a9,1x,i6,1p,6(1x,e10.3))
end subroutine printstats

end module innovstats


C    @(#)xout_bus.f	20.4 2/13/96
C****************************************************************
C
C   File: xout_bus.f
C   Purpose: Routine to obtain BCD image of INPUT/OUTPUT/SYSTEM
C            data from alternate base case.  Note that this is
c            a limited edition of the original out_bus module.
c            The limitation is that the alternate data set excludes
c            some bus input data and some data accessing routines.
C
C   Author: Walt Powell  Date: 26 July 1993
C                        Modified:
C   Called by:
C
C****************************************************************
C
        subroutine xout_bus (nb, datarec)

        character datarec * (*)
c
c       This subroutine returns WSCC-formated output data records.
c       Output parameter:
c
c       datarec - a character string for storing data
c
        include 'ipfinc/parametr.inc'

        include 'ipfinc/blank.inc'
c	Global variables used:
c		bmva
        include 'ipfinc/lfiles.inc'
c	Global variables used:
c		None
        include 'ipfinc/prt.inc'
c	Global variables used:
c		None
        include 'ipfinc/alt_case.inc'
c	Global variables used:
c		okdcmtb, oldowner, oldbus, okdc2t, ontypu,
c		oinp2opt, oqnetu, oqloadu, odcmtbs, odc2t,
c		oldbase, okdtot, omtdcbs, olde, oldf
c
        character type * 1, xcode * 4, code * 4
c
        xcode = code (oldbase(nb), 4, 0)
        kt = oinp2opt(nb)
	ntyp = ontypu(kt)
        call typno (type, ntyp)

        write (datarec, 100) type, oldowner(nb), oldbus(nb), xcode,
     &         oldzone(nb)
  100   format ('B', a, t4, a, t7, a, a, a)

	if (ntyp .eq. 5) then
           do idc = 1, okdtot
               if (okdc2t(1,idc) .eq. nb ) go to 10
               if (okdc2t(3,idc) .eq. nb ) go to 20
           enddo

   10      pdc = odc2t(42,idc)
           qdc = odc2t(44,idc)
           pvlv = abs(pdc - 0.001 * odc2t(40,idc) * odc2t(39,idc))
           qvlv = qdc
           dci = odc2t(39,idc)
           angle = 57.2957795 * odc2t(22,idc)
           vdc = odc2t(40,idc)
           go to 30

   20      pdc = odc2t(43,idc)
           qdc = odc2t(45,idc)
           pvlv = abs(pdc + 0.001 * odc2t(41,idc) * odc2t(39,idc))
           qvlv = qdc
           dci = -odc2t(39,idc)
           angle = 57.2957795 * odc2t(26,idc)
           vdc = odc2t(41,idc)

   30      write( datarec(21:), 40 )  pdc, qdc, vdc, angle, pvlv,
     1                                   qvlv
   40      format(6e15.7)

        else if (ntyp .eq. 12) then

           do idc = 1, omtdcbs
               if (okdcmtb(1,idc) .eq. nb ) go to 110
           enddo
           call erexit
  110      if (okdcmtb(3,idc) .eq. 0) then
              pdc = 0.0
              qdc = 0.0
              pvlv = 0.0
              qvlv = 0.0
              dci = 0.0
	      angle = 0.0
              vdc = 0.0
           else
              pdc = odcmtbs(25,idc)
              qdc = odcmtbs(26,idc)
              pvlv = abs(pdc - odcmtbs(19,idc))
              qvlv = qdc
              dci = 1000.0 * odcmtbs(19,idc) / odcmtbs(20,idc)
              angle = 57.2957795 * odcmtbs(13,idc)
              vdc = odcmtbs(24,idc)
           endif
           write( datarec(21:), 40 )  pdc, qdc, vdc, angle, pvlv,
     1                                qvlv
        else

           pload = (oploadu(kt) + oinetr(kt) * vk) * bmva
           qload = (oqloadu(kt) - oineti(kt) * vk) * bmva
           pgen = (opnetu(kt) - oinetr(kt) * vk) * bmva + pload
           vk = sqrt (olde(kt) ** 2 + oldf(kt) ** 2)
           voltkv = vk * oldbase(nb)

           if (olde(kt) .eq. 0.0 .and. oldf(kt) .eq. 0.0) then
              degree = 0.0
           else
              degree = 57.2957795 * atan2( oldf(kt), olde(kt) )
           endif
           pvlv = 0.0
           qvlv = 0.0
           call typno( type, ntyp )
           call xallocq(nb, oqnetu(kt), qgen, qgnmax, qgnmin, qld,
     &                  totcap, usecap, totrek, userek, unsked, qerr)
           if ( usecap + unsked .gt. 0.0 ) then
              if ( totcap .gt. 0.0 ) then
                 bsched = totcap
              else
                 bsched = totrek
              end if
              bused = usecap + unsked
           else if ( userek + unsked .lt. 0.0 ) then
              if ( totrek .lt. 0.0 ) then
                 bsched = totrek
              else
                 bsched = totcap
              end if
              bused = userek + unsked
           else if ( unsked .lt. 0.0 ) then
              if ( totrek .lt. 0.0 ) then
                 bsched = totrek
              else
                 bsched = totcap
              end if
              bused = unsked
           else if ( unsked .gt. 0.0 ) then
              if ( totcap .gt. 0.0 ) then
                 bsched = totcap
              else
                 bsched = totrek
              end if
              bused = unsked
           else if ( totrek .lt. 0.0 .and. totcap .eq. 0.0 ) then
              bsched = totrek
              bused = userek
           else
              bsched = totcap
              bused = usecap
           end if
           write( datarec(21:), 160 )  pgen, qgen, voltkv, degree,
     &                                 pload, qload, bused, bsched,
     &                                 usecap, totcap, userek, totrek,
     &                                 unsked
  160      format(13e15.7)
	endif
	return
	end


        subroutine quelle_grille(emax,nen,centE,botE,ddeng,
     &                          nang,nango2,gmu,gwt,angzb)

 	    implicit none

        include 'TRANSPORT.INC'
c
c 	Entree du programme : La valeur caracteristique de l'energie
c 	des precipitations
c
c 	Sorties : nombres d'energie, d'angles
c 	grille d'energie (centre de grille, bas, largeur)
c 	grille d'angle (angle, cosinus, poids)

     	integer nen,nang,nango2
     	integer i1,i2,i3
     	real centE(nbren),botE(nbren),ddeng(nbren)
     	real angzb(2*nbrango2),gmu(2*nbrango2),gwt(2*nbrango2)
c
c 	Parametres internes :
     	real spfac,emax,emin	   !calcul eventuel d'une grille propre
     	integer ien,iang,iost
      character(len=80),parameter ::
     &        datdegfn = 'dir.data/dir.linux/dir.cine/DATDEG'

c 	Pour transferer via DATDEG les caracteristiques de grille a
c 	degrad.f
 	    integer type_de_grille,lenc,idess(2),iprint1,iprint2,iprint3,
     &		iprint4
 	    logical logint,lt1,lt2,lt3,lt4,lopal
        character*80 crsin,crs,rdt,crsfn
c
 	    real,parameter :: pideg=57.29578
c
c 	On stoke les parametres de calcul de degrad.
        open(fic_datdeg, file=datdegfn, status='old')

        rewind(fic_datdeg)
     	read(fic_datdeg,*) type_de_grille
     	if(type_de_grille .eq.0) then
        print*,'DATDEG specifies grid type 0'
     	  close(fic_datdeg)
     	  return
     	endif
        read(fic_datdeg,1000) crsin
        crsin = crsin(1:lenc(crsin))
        read(fic_datdeg,1000) crs
        crs = crs(1:lenc(crs))
        read(fic_datdeg,1000) rdt
        rdt = rdt(1:lenc(rdt))
        call xline(4,fic_datdeg) !skip 4 lines
        read (fic_datdeg,*) idess(1),idess(2)
        call xline(2,fic_datdeg) !skip 2 lines
        read (fic_datdeg,*) iprint1,iprint2,iprint3,iprint4
        read(fic_datdeg,1000) logint
        read(fic_datdeg,1000) lt1
        read(fic_datdeg,1000) lt2
        read(fic_datdeg,1000) lt3
        read(fic_datdeg,1000)lt4
        read(fic_datdeg,1000)lopal
 	    close(fic_datdeg)

!-MZ
        emax=70000.
!-MZ

 	   if (type_de_grille.eq.1)then
c 	  On utilise les grilles detaillees
!     "use detailed grid"
   	  if (emax.le.355.8)then
   	    crs = 'dir.cine/dir.seff/crsa1'
   	    rdt = 'dir.cine/dir.seff/rdta1'
 	    else if (emax.gt.355.8 .and. emax.le.720.6)then
   	    crs = 'dir.cine/dir.seff/crsa2'
   	    rdt = 'dir.cine/dir.seff/rdta2'
 	    else if (emax.gt.720.6 .and. emax.le.2193.)then
   	    crs = 'dir.cine/dir.seff/crsa3'
   	    rdt = 'dir.cine/dir.seff/rdta3'
 	    else if (emax.gt.2193. .and. emax.le.4394.)then
   	    crs = 'dir.cine/dir.seff/crsa4'
   	    rdt = 'dir.cine/dir.seff/rdta4'
 	    else if (emax.gt.4394. .and. emax.le.7057.)then
   	    crs = 'dir.cine/dir.seff/crsa5'
   	    rdt = 'dir.cine/dir.seff/rdta5'
 	    else if (emax.gt.7057. .and. emax.le.21700.)then
   	    crs = 'dir.cine/dir.seff/crsa6'
   	    rdt = 'dir.cine/dir.seff/rdta6'
 	    else if (emax.gt.21700. .and. emax.le.43410.)then
   	    crs = 'dir.cine/dir.seff/crsa7'
   	    rdt = 'dir.cine/dir.seff/rdta7'
 	    else if (emax.gt.43410. .and. emax.le.70440.)then
   	    crs = 'dir.cine/dir.seff/crsa8'
   	    rdt = 'dir.cine/dir.seff/rdta8'
 	    else
   	    nen = 400
   	    crs = 'dir.cine/dir.seff/crsa'
   	    rdt = 'dir.cine/dir.seff/rdta'
   	    emin = 1.e-01
!	    On ne va pas au dessus de 140 keV...
!     "do not go above 140keV (?) "
   	    emax = min(emax,140000.0)
              print*,'call gridpolo'
            call gridpolo (nen,emin,emax,centE,ddeng,spfac)
c           Calcul des energies de bas de grille
            botE(1) = max(centE(1) - ddeng(1)/2.,1.e-03)
            do ien = 1,nen-1
              botE(ien+1) = botE(ien)+ddeng(ien+1)
            enddo
      print*,'using detail grid type 1, crs,rdt: ',crs,rdt
 	    endif

 	  else if (type_de_grille.eq.2)then
   	  if (emax.le.355.8)then
   	    crs = 'dir.cine/dir.seff/crsb1'
   	    rdt = 'dir.cine/dir.seff/rdtb1'
   	  else if (emax.gt.355.8 .and. emax.le.720.6)then
   	    crs = 'dir.cine/dir.seff/crsb2'
   	    rdt = 'dir.cine/dir.seff/rdtb2'
   	  else if (emax.gt.720.6 .and. emax.le.2193.)then
   	    crs = 'dir.cine/dir.seff/crsb3'
   	    rdt = 'dir.cine/dir.seff/rdtb3'
   	  else if (emax.gt.2193. .and. emax.le.4394.)then
   	    crs = 'dir.cine/dir.seff/crsb4'
   	    rdt = 'dir.cine/dir.seff/rdtb4'
   	  else if (emax.gt.4394. .and. emax.le.7057.)then
   	    crs = 'dir.cine/dir.seff/crsb5'
   	    rdt = 'dir.cine/dir.seff/rdtb5'
   	  else if (emax.gt.7057. .and. emax.le.21700.)then
   	    crs = 'dir.cine/dir.seff/crsb6'
   	    rdt = 'dir.cine/dir.seff/rdtb6'
   	  else if (emax.gt.21700. .and. emax.le.43410.)then
   	    crs = 'dir.cine/dir.seff/crsb7'
   	    rdt = 'dir.cine/dir.seff/rdtb7'
   	  else if (emax.gt.43410. .and. emax.le.70440.)then
   	    crs = 'dir.cine/dir.seff/crsb8'
   	    rdt = 'dir.cine/dir.seff/rdtb8'
   	  else
   	    nen = 150
   	    crs = 'dir.cine/dir.seff/crsb'
   	    rdt = 'dir.cine/dir.seff/rdtb'
   	    emin = 1.e-01
c 	    On ne va pas au dessus de 140 keV...
   	    emax = min(emax,140000.0)
              call gridpolo (nen,emin,emax,centE,ddeng,spfac)
c           Calcul des energies de bas de grille         :
              botE(1) = max(centE(1) - ddeng(1)/2.,1.e-03)
              do ien = 1,nen-1
                botE(ien+1) = botE(ien)+ddeng(ien+1)
              enddo
   	   endif
      print*,'using detail grid type 2, crs,rdt: ',crs,rdt
 	    endif
c
c       Lecture des grilles d'energie.
c	goto 314
        crsfn = 'dir.data/dir.linux/'//crs
        print*,'attempting to open ',crsfn
        open(icrsin,file=crsfn,
     &       status='OLD',form='UNFORMATTED',
     &          iostat=iost,err=992)
        rewind icrsin
        read(icrsin) nen,i1,i2,i3
        read(icrsin) (centE(ien),ien=1,nen)
        read(icrsin) (botE(ien),ien=1,nen)
        read(icrsin) (ddeng(ien),ien=1,nen)
        close(icrsin)

c314 	    nen = 40
c 	    crs = 'dir.cine/dir.seff/crsb1'
c 	    rdt = 'dir.cine/dir.seff/rdtb1'
c 	    emin = 1.e-01
cc 	    On ne va pas au dessus de 140 keV...
c 	    emax = 355.8
c            call gridpolo (nen,emin,emax,centE,ddeng,spfac)
cc           Calcul des energies de bas de grille
c            botE(1) = max(centE(1) - ddeng(1)/2.,1.e-03)
c            do ien = 1,nen-1
c              botE(ien+1) = botE(ien)+ddeng(ien+1)
c            enddo
c
c 	On previent maintenant degrad de ou il faut lire les sections
c 	efficaces.
        print*,'attempting to open ',datdegfn
        open(fic_datdeg,file=datdegfn,
     &       status='unknown',err=993) !yes unknown in case not all values rewritten
!        rewind(fic_datdeg)
       print*,'beginning to rewrite',datdegfn
     	write(fic_datdeg,1010)type_de_grille
        write(fic_datdeg,1020) crsin
        write(fic_datdeg,1030) crs
        write(fic_datdeg,1040) rdt
        write(fic_datdeg,1050) idess(1),idess(2)
        write(fic_datdeg,1060) iprint1,iprint2,iprint3,iprint4

 	    if(logint)then
          write(fic_datdeg,1070)
 	    else
          write(fic_datdeg,1075)
 	    endif
1070 	format('.true.',11x,
     &    'logint: interpolation type for cross sections')
1075 	format('.false.',10x,
     &    'logint: interpolation type for cross sections')
c
     	if(lt1)then
          write(fic_datdeg,1080)
     	else
          write(fic_datdeg,1085)
     	endif
1080 	format('.true.',11x,'lt1   : test without ionization')
1085 	format('.false.',10x,'lt1   : test without ionization')

     	if(lt2)then
              write(fic_datdeg,1090)
     	else
              write(fic_datdeg,1095)
     	endif
1090 	format('.true.',11x,'lt2   : test only with ionization')
1095 	format('.false.',10x,'lt2   : test only with ionization')

     	if(lt3)then
              write(fic_datdeg,1100)
     	else
              write(fic_datdeg,1105)
     	endif
1100 	format('.true.',11x,'lt3   : test without degradation')
1105 	format('.false.',10x,'lt3   : test without degradation')

     	if(lt4)then
              write(fic_datdeg,1110)
     	else
              write(fic_datdeg,1115)
     	endif
1110 	format('.true.',11x,'lt4   : test without excitation')
1115 	format('.false.',10x,'lt4   : test without excitation')

     	if(lopal)then
              write(fic_datdeg,1120)
     	else
              write(fic_datdeg,1125)
     	endif
1120 	format('.true.',11x,
     &    'lopal : sec. distrib. de Opal (Rees sinon)')
1125 	format('.false.',10x,
     &    'lopal : sec. distrib. de Opal (Rees sinon)')

 	  close(fic_datdeg)
c
1000    format(a)
1010 	format(i2,10x,' for iniflu : 1 use detailed grid, 2 coarse grid')
c1020 	format(a,3x,' Fichier d''entree des sections efficaces')
c1030 	format(a,3x,' Fichier de sortie des seff(E)')
c1040 	format(a,3x,' Fic. de sortie des seff diff. (Eprim-->E)')
1020 	format(a)
1030 	format(a)
1040 	format(a)
1050 	format('idess =-1 no plot.',/,
     &    'idess = 0 metacode created, without interactive session.',/,
     &    'idess = 1 metacode not created, but screened plots.',/,
     &    'idess = 2 metacode created, with interactive session.',/,
     &   2i5,5x,'(seff, seff detailled)')
1060 	format('iprint = 1 if print (whatever number otherwise)',/,
     &    8x,'sigel  siginel  rmatrix diff-sig-test ',/,4i10)
1130 	format(a7)
c
        nang=8
        nango2=nang/2

        gmu(1)= .9305681586266
        gmu(2)= .6699905395508
        gmu(3)= .3300094604492
        gmu(4)= .0694318413734
        gmu(5)=-.0694318413734
        gmu(6)=-.3300094604492
        gmu(7)=-.6699905395508
        gmu(8)=-.9305681586266

        gwt(1)=.1739274263382
        gwt(2)=.3260725736618
        gwt(3)=.3260725736618
        gwt(4)=.1739274263382
        gwt(5)=.1739274263382
        gwt(6)=.3260725736618
        gwt(7)=.3260725736618
        gwt(8)=.1739274263382

        do iang=1,nang
          angzb(iang)=pideg*acos(gmu(iang))
        enddo
c
 	    return

992     print*,' Cross-section file is in error. Status=',iost
     	stop

993     print*,' trouble writing crs file'
        stop

        end subroutine quelle_grille


C    Copyright (c) 2014, Sandia Corporation.
C    Under the terms of Contract DE-AC04-94AL85000 with Sandia Corporation,
C    the U.S. Government retains certain rights in this software.
C
C    Redistribution and use in source and binary forms, with or without
C    modification, are permitted provided that the following conditions are
C    met:
C
C        * Redistributions of source code must retain the above copyright
C          notice, this list of conditions and the following disclaimer.
C
C        * Redistributions in binary form must reproduce the above
C          copyright notice, this list of conditions and the following
C          disclaimer in the documentation and/or other materials provided
C          with the distribution.
C
C        * Neither the name of Sandia Corporation nor the names of its
C          contributors may be used to endorse or promote products derived
C          from this software without specific prior written permission.
C
C    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C    A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C    OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C    SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C    LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C    DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C    THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C    (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C    OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
C

C $Id: arcpar.f,v 1.2 1991/03/21 15:44:18 gdsjaar Exp $
C $Log: arcpar.f,v $
C Revision 1.2  1991/03/21 15:44:18  gdsjaar
C Changed all 3.14159... to atan2(0.0, -1.0)
C
c Revision 1.1.1.1  1990/11/30  11:03:41  gdsjaar
c FASTQ Version 2.0X
c
c Revision 1.1  90/11/30  11:03:40  gdsjaar
c Initial revision
c
C
CC* FILE: [.MAIN]ARCPAR.FOR
CC* MODIFIED BY: TED BLACKER
CC* MODIFICATION DATE: 7/6/90
CC* MODIFICATION: COMPLETED HEADER INFORMATION
C
      SUBROUTINE ARCPAR (MP, KT, KNUM, COOR, LINKP, IPNTR1, IPNTR2,
     &   IPNTR3, IP3, XCEN, YCEN, THETA1, THETA2, TANG, R1, R2, ERR,
     &   ICCW, ICW, XK, XA)
C***********************************************************************
C
C  SUBROUTINE ARCPAR = THIS ROUTINE CALCULATES THE ARC PARAMETERS
C
C***********************************************************************
C
C  VARIABLES USED:
C     TANG   = TOTAL ANGLE SCRIBED BY THE ARC
C     THETA1 = FIRST CCW ANGLE OF THE ARC
C     THETA2 = SECOND CCW ANGLE OF THE ARC
C     IPNTR1 = POINTER TO FIRST COORDINATE VALUE
C     IPNTR2 = POINTER TO SECOND COORDINATE VALUE
C     IPNTR3 = POINTER TO THIRD COORDINATE VALUE
C     IP3    = THE THIRD POINT NUMBER (CAN BE NEGATED)
C
C***********************************************************************
C
      DIMENSION COOR (2, MP), LINKP (2, MP)
C
      LOGICAL ERR
C
      PI = ATAN2(0.0, -1.0)
      TWOPI = PI + PI
      ERR = .FALSE.
C
C  ARC WITH CENTER GIVEN
C  ARC GOES FROM 1ST POINT TO 2ND IN *COUNTER-CLOCKWISE* DIRECTION.
C
      IF (KT .EQ. 3) THEN
         XCEN = COOR (1, IPNTR3)
         YCEN = COOR (2, IPNTR3)
C
C  CIRCLE WITH THIRD POINT ON ARC
C
      ELSEIF (KT .EQ. 4) THEN
         THETA1 = ATAN2 (COOR (2, IPNTR3) - COOR (2, IPNTR1),
     &      COOR (1, IPNTR3) - COOR (1, IPNTR1)) + PI / 2.0
         THETA2 = ATAN2 (COOR (2, IPNTR3) - COOR (2, IPNTR2),
     &      COOR (1, IPNTR3) - COOR (1, IPNTR2)) + PI / 2.0
         DET = - COS (THETA1) * SIN (THETA2) +
     &      COS (THETA2) * SIN (THETA1)
         X11 = 0.5 * (COOR (1, IPNTR1) + COOR (1, IPNTR3))
         Y11 = 0.5 * (COOR (2, IPNTR1) + COOR (2, IPNTR3))
         X21 = 0.5 * (COOR (1, IPNTR2) + COOR (1, IPNTR3))
         Y21 = 0.5 * (COOR (2, IPNTR2) + COOR (2, IPNTR3))
         R =  ( - SIN (THETA2) * (X21 - X11) +
     &      COS (THETA2) * (Y21 - Y11)) / DET
         XCEN = X11 + R * COS (THETA1)
         YCEN = Y11 + R * SIN (THETA1)
C
C     CIRCLE WITH RADIUS GIVEN
C
      ELSEIF (KT .EQ. 6) THEN
         DX = 0.5 * (COOR (1, IPNTR2) - COOR (1, IPNTR1))
         DY = 0.5 * (COOR (2, IPNTR2) - COOR (2, IPNTR1))
         CHORD = SQRT (DX * DX + DY * DY)
         R = ABS (COOR (1, IPNTR3))
         IF (R .LE. CHORD) THEN
            XCEN = 0.5 * (COOR (1, IPNTR1) + COOR (1, IPNTR2))
            YCEN = 0.5 * (COOR (2, IPNTR1) + COOR (2, IPNTR2))
         ELSE
            ARM = SQRT (R * R - CHORD * CHORD)
            IF (IP3.LT.0) THEN
               XCEN = COOR (1, IPNTR1) + DX + ARM * DY / CHORD
               YCEN = COOR (2, IPNTR1) + DY - ARM * DX / CHORD
            ELSE
               XCEN = COOR (1, IPNTR1) + DX - ARM * DY / CHORD
               YCEN = COOR (2, IPNTR1) + DY + ARM * DX / CHORD
            ENDIF
         ENDIF
      ENDIF
C
C  CHECK TO MAKE SURE THAT THE BEGINNING AND ENDING RADIUS EXIST
C
      IF ((( COOR (1, IPNTR1) .EQ. XCEN) .AND.
     &   (COOR (2, IPNTR1) .EQ. YCEN)) .OR.
     &   ((COOR (1, IPNTR2) .EQ. XCEN) .AND.
     &   (COOR (2, IPNTR2) .EQ. YCEN))) THEN
         CALL PLTFLU
         WRITE (*, 10000) ABS (KNUM)
         ERR = .TRUE.
         GOTO 100
      ENDIF
      R1 = SQRT ( (COOR (1, IPNTR1) - XCEN) **2 +  (COOR (2, IPNTR1) -
     &   YCEN) **2)
      R2 = SQRT ( (COOR (1, IPNTR2) - XCEN) **2 +  (COOR (2, IPNTR2) -
     &   YCEN) **2)
      THETA1 = ATAN2 (COOR (2, IPNTR1) - YCEN, COOR (1, IPNTR1) - XCEN)
      THETA2 = ATAN2 (COOR (2, IPNTR2) - YCEN, COOR (1, IPNTR2) - XCEN)
C
C  ARC WITH THE CENTER GIVEN
C
      IF (KT .EQ. 3) THEN
         IF  (IPNTR1 .EQ. IPNTR2) THEN
            THETA2  =  THETA1  +  TWOPI
         ELSEIF ((IP3 .GE. 0) .AND. (THETA2 .LE. THETA1)) THEN
            THETA2 = THETA2 + TWOPI
         ELSEIF ((IP3 .LT. 0) .AND. (THETA1 .LE. THETA2)) THEN
            THETA1 = THETA1 + TWOPI
         ENDIF
         TANG = THETA2 - THETA1
         IF (IP3 .LT. 0) THEN
            ICCW = IPNTR2
            ICW = IPNTR1
         ELSE
            ICCW = IPNTR1
            ICW = IPNTR2
         ENDIF
C
C  CIRCULAR ARC WITH 3RD POINT ON ARC - CLOCKWISE OR COUNTER-CLOCKWISE
C
      ELSEIF (KT .EQ. 4) THEN
         THETA3 = ATAN2 (COOR (2, IPNTR3) - YCEN, COOR (1, IPNTR3) -
     &      XCEN)
         IF (THETA2 .LE. THETA1) THETA2 = THETA2 + TWOPI
         IF (THETA3 .LE. THETA1) THETA3 = THETA3 + TWOPI
         TANG = THETA2 - THETA1
         IF (THETA3 .GT. THETA2) THEN
            TANG = - (TWOPI - TANG)
            ICCW = IPNTR2
            ICW = IPNTR1
         ELSE
            ICCW = IPNTR1
            ICW = IPNTR2
         ENDIF
C
C     CIRRCULAR ARC WITH RADIUS GIVEN - CLOCKWISE OR COUNTER-CLOCKWISE
C
      ELSEIF (KT .EQ. 6) THEN
         IF ( (IP3 .GE. 0) .AND. (THETA2 .LE. THETA1))
     &      THETA2 = THETA2 + TWOPI
         IF ( (IP3 .LT. 0) .AND. (THETA1 .LE. THETA2))
     &      THETA1 = THETA1 + TWOPI
         TANG = THETA2 - THETA1
         IF (IP3 .GE. 0) THEN
            ICCW = IPNTR1
            ICW = IPNTR2
         ELSE
            ICCW = IPNTR2
            ICW = IPNTR1
         ENDIF
      ENDIF
C
C  DEFINE THE SPIRAL PARAMETERS  (R = XA * EXP  (XK * THETA))
C
      XK = (LOG (R2 / R1)) / (THETA2 - THETA1)
      DIVID = EXP (XK * THETA2)
      IF (DIVID .GT. 0.) THEN
         XA = R2 / DIVID
      ELSE
         WRITE (*, 10010) IABS (KNUM)
         ERR = .TRUE.
         GOTO 100
      ENDIF
C
  100 CONTINUE
C
      RETURN
C
10000 FORMAT (' CENTER POINT FOR LINE', I5, ' LIES ON ONE OF',
     &   ' THE ENDPOINTS')
10010 FORMAT (' DEFINITION FOR ARC LINE', I5, ' IS INVLAID')
C
      END


!+ Source Code for reading cosmo binary restart files
!------------------------------------------------------------------------------

program readCOSMObinr

!------------------------------------------------------------------------------
!
! Description:
!  This code is based on COSMO5.1 routines for reading COSMO binary restart files
!  Current Code Owner: P. Shrestha
!    email: pshrestha@uni-bonn.de
!  History:
!  Version    Date       Name
!  ---------- ---------- ----
!  1.1        2016/06/03 P. Shrestha
!  Initial release
!
! Code Description:
! Language: Fortran 90.
! Software Standards: "European Standards for Writing and
! Documenting Exchangeable Fortran 90 Code".
!
!> @TODO ... what is the table and code for pressure or pressure perturbations
!> @TODO ... what is the table and code for cloud ice
!> @TODO ... what temperature is the prognostic variable
!> @TODO ... vertical ... everything ...
!
!==============================================================================

IMPLICIT NONE

INTEGER, PARAMETER :: intgribf  = KIND(1)
INTEGER, PARAMETER :: iintegers = KIND(1)
INTEGER, PARAMETER :: sp = SELECTED_REAL_KIND( 6, 37)
INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12,307)
INTEGER, PARAMETER :: wp = dp

! Table to decode the record contents of igdsbuf
integer, parameter :: indx_numEW    =  5, &
                      indx_numNS    =  6, &
                      indx_startlat =  7, &
                      indx_startlon =  8, &
                      indx_endlat   = 10, &
                      indx_endlon   = 11

! Table to decode the record contents of ipdsbuf
!> @TODO no seconds?
integer, parameter :: indx_gribver   =   2, &
                      indx_var       =   7, &
                      indx_zlevtyp   =   8, &
                      indx_zlevtop   =   9, &
                      indx_zlevbot   =  10, &
                      indx_year      =  11, &
                      indx_mm        =  12, &
                      indx_dd        =  13, &
                      indx_hh        =  14, &
                      indx_min       =  15, &
                      indx_startstep =  17, &
                      indx_endstep   =  18, &
                      indx_nztri     =  19, &
                      indx_cc        =  22

INTEGER (KIND=intgribf),  PARAMETER ::  &
              npds  = 321_intgribf, & ! dimension of product definition section
              ngds  = 626_intgribf    ! dimension of grid description section

INTEGER (KIND=iintegers), PARAMETER ::  &
              idim  = 30, &           ! dimesion of longitude
              jdim  = 20, &           ! dimension of latitutde
              kdim  = 249              ! dimension of vertical co-ordinate

INTEGER (KIND=iintegers) ::  &
              nudat,      &           ! unit number
              izerr,      &           ! error status
              ivar,       &           ! variable reference number based on iver
              iver,       &           ! version number of GRIB1 indicator table
              iz_countl               ! counter for binary data

integer :: i, nx, ny, ilev, ilevp1, ilevtyp
integer :: icc, iyy, imm, idd, ihh, imin, iccyy
integer :: istartstep, iendstep, nztri
real(kind=wp) lat1, latN, lon1, lonN

REAL(KIND=wp) ::  &
              rbuf(idim*jdim),  &     ! data to be read
              psm0,             &     ! initial value for mean surface pressure ps
              dsem0,            &     ! initial value for mean dry static energy
              msem0,            &     ! initial value for mean moist static energy
              kem0,             &     ! initial value for mean kinetic energy
              qcm0,             &     ! initial value for mean cloudwater content
              refatm_p0sl,      &     ! constant reference pressure on sea-level
              refatm_t0sl,      &     ! constant reference temperature on sea-level
              refatm_dt0lp,     &     ! d (t0) / d (ln p0)
              refatm_delta_t,   &     ! temperature difference between sea level and stratosphere (for irefatm=2)
              refatm_h_scal,    &     ! scale height (for irefatm=2)
              refatm_bvref,     &     ! constant Brund-Vaisala-frequency for irefatm=3
              vcoord_vcflat,    &     ! coordinate where levels become flat
              zvc_params(kdim+1)      ! vertical coordinate - heights?

INTEGER(KIND=intgribf) :: &
             ipdsbuf(npds), &         ! pds: product definition section
             igdsbuf(ngds)            ! gds: grid definition section

INTEGER(KIND=iintegers) :: &
             ntke,         &          ! time level for TKE
             izvctype_read            ! check vertical coordinate type in restarts

CHARACTER(LEN=*), PARAMETER :: datname = "data/lrff00030000o"

!------------------------------------------------------------------------------
!Variable Defininiton Complete, program starts here

!------------------------------------------------------------------------------
!Section 1: INITIALIZE
!------------------------------------------------------------------------------

write(*,*)'iintegers is ',iintegers

nudat = 100

!------------------------------------------------------------------------------
!Section 2: OPEN BINARY RESTART FILE
!------------------------------------------------------------------------------

OPEN (nudat, FILE=TRIM(datname), FORM='UNFORMATTED', STATUS='OLD', &
                  ACTION='READ', IOSTAT=izerr)
IF (izerr /= 0) then
   write(*,*)'ERROR: unable to open file "'//trim(datname)//'".'
   STOP
endif

REWIND(nudat)

READ (nudat, IOSTAT=izerr) psm0, dsem0, msem0, kem0, qcm0, ntke
IF (izerr /= 0) then
   write(*,*)'ERROR: unable to read first record.'
   STOP
endif

write(*,*)'first record had ', psm0, dsem0, msem0, kem0, qcm0, ntke

READ (nudat,IOSTAT=izerr) izvctype_read, refatm_p0sl,   refatm_t0sl,   &
                                refatm_dt0lp, vcoord_vcflat, zvc_params
IF (izerr /= 0) then
   write(*,*)'ERROR: unable to read second record.'
   STOP
endif

write(*,*)'second record had', izvctype_read, refatm_p0sl,   refatm_t0sl,   &
                                refatm_dt0lp, vcoord_vcflat, zvc_params

IF     ( (izvctype_read >   0) .AND. (izvctype_read <= 100) ) THEN
  PRINT*, "izvctype_read = ", izvctype_read
ELSEIF ( (izvctype_read > 100) .AND. (izvctype_read <= 200) ) THEN
  READ (nudat,IOSTAT=izerr) refatm_delta_t, refatm_h_scal
  write(*,*)'aux record was ',refatm_delta_t, refatm_h_scal
  IF (izerr /= 0) STOP
ELSEIF ( (izvctype_read > 200) .AND. (izvctype_read <= 300) ) THEN
  READ (nudat,IOSTAT=izerr) refatm_bvref
  write(*,*)'aux record was ', refatm_bvref
  IF (izerr /= 0) STOP
ELSEIF ( izvctype_read > 300 ) THEN
  write(*,*)'ERROR: izvctype_read is ',izvctype_read,' which is greater than max expected (300)'
  stop
ENDIF

!------------------------------------------------------------------------------
!Section 3: READ ALL RECORDS
!------------------------------------------------------------------------------

iz_countl = 0

read_loop: DO

  READ (nudat, IOSTAT=izerr) ipdsbuf, igdsbuf, rbuf

  IF (izerr < 0) THEN
    WRITE (*,*) ' EOF reached after ',iz_countl,' data records.'
    exit read_loop
  ELSEIF (izerr > 0) THEN
    WRITE (*,*) 'ERROR READING RESTART FILE around data record ',iz_countl
    exit read_loop
  ENDIF

  iz_countl = iz_countl + 1

  ! Decode ipdsbuf

  iver    = ipdsbuf(indx_gribver)
  ivar    = ipdsbuf(indx_var)
  ilevtyp = ipdsbuf(indx_zlevtyp)
  ilev    = ipdsbuf(indx_zlevtop)
  ilevp1  = ipdsbuf(indx_zlevbot)

  icc     = ipdsbuf(indx_cc)-1
  iyy     = ipdsbuf(indx_year)
  iccyy   = iyy + icc*100
  imm     = ipdsbuf(indx_mm)
  idd     = ipdsbuf(indx_dd)
  ihh     = ipdsbuf(indx_hh)
  imin    = ipdsbuf(indx_min)

  istartstep = ipdsbuf(indx_startstep)
  iendstep   = ipdsbuf(indx_endstep)
  nztri      = ipdsbuf(indx_nztri)

! write(*,'(A,3x,i8,5(1x,i2),3(1x,i4))') 'time for iz_countl = ', &
!        iz_countl,icc,iyy,imm,idd,ihh,imin,nztri,istartstep,iendstep

  ! Decode igdsbuf

  nx   = igdsbuf(indx_numEW)
  ny   = igdsbuf(indx_numNS)
  lat1 = real(igdsbuf(indx_startlat),wp) * 0.001_wp
  lon1 = real(igdsbuf(indx_startlon),wp) * 0.001_wp
  latN = real(igdsbuf(indx_endlat  ),wp) * 0.001_wp
  lonN = real(igdsbuf(indx_endlon  ),wp) * 0.001_wp

  ! Since Fortran binary reads have no way to know if they fail or not
  ! we are going to compare our input with the sizes encoded in the file.

  if (nx .ne. idim .or. ny .ne. jdim) then
     write(*,*)'ERROR: (file) nx /= idim ',nx,idim, ' or '
     write(*,*)'ERROR: (file) ny /= jdim ',ny,jdim
     stop
  endif

  ! debug code ... 3300 does not exist
  if (iver == 2 .and. ivar == 3300) then
     do i = 1,npds
        write(*,*)iver, ivar, 'ipdsbuf(',i,') = ',ipdsbuf(i)
     enddo

     do i = 1,ngds
        write(*,*)iver, ivar, 'igdsbuf(',i,') = ',igdsbuf(i)
     enddo
  endif

  write (*,'( 7(1x,i4),2(1xf15.8))') iver, ivar, nx, ny, ilev, ilevp1, ilevtyp, MINVAL(rbuf), MAXVAL(rbuf)

ENDDO read_loop

CLOSE (nudat, IOSTAT=izerr)

end program readCOSMObinr


      subroutine qg_tbqdk_gs(p,msq)
************************************************************************
*     Real subtraction for t-channel single top, with explicit b-quark *
*                                                                      *
*     q(p1) + g(p2) -> t(p3) + b(p4) + q'(p5) + g(p6)                  *
*                                                                      *
*      (and related crossings and MEs)                                 *
*                                                                      *
*     Author: J. Campbell, March 18, 2008                              *
*                         (added decay May 2011)                       *
*                                                                      *
************************************************************************
*                                                                      *
*    Modified so that off-diagonal subtractions are initial-final      *
*                                                                      *
************************************************************************
      implicit none
      include 'constants.f'
      include 'masses.f'
      include 'ckm.f'
      include 'ptilde.f'
      include 'qcdcouple.f'
      include 'qqgg.f'
      include 'noglue.f'
      include 'stopscales.f'
      include 'breit.f'
      double precision corrL,corrH
      double precision p(mxpart,4),msq(maxd,-nf:nf,-nf:nf)
      double precision
     . msq16_5(-nf:nf,-nf:nf),sub16_5(4),
     . msq56_1(-nf:nf,-nf:nf),sub56_1(4),
     . msq26_4(-nf:nf,-nf:nf),sub26_4(4),
     . msq46_2(-nf:nf,-nf:nf),sub46_2(4),
     . msq26_3(-nf:nf,-nf:nf),sub26_3(4),
     . msq36_2(-nf:nf,-nf:nf),sub36_2(4),
     . msq36_4(-nf:nf,-nf:nf),sub36_4(4),
     . msq46_3(-nf:nf,-nf:nf),sub46_3(4),
     . msq26_4v(-nf:nf,-nf:nf),sub26_4v,
     . msq26_3v(-nf:nf,-nf:nf),sub26_3v,
     . msq26_5(-nf:nf,-nf:nf),sub26_5(4),
     . msq56_2(-nf:nf,-nf:nf),sub56_2(4),
     . msq16_4(-nf:nf,-nf:nf),sub16_4(4),
     . msq46_1(-nf:nf,-nf:nf),sub46_1(4),
     . msq16_3(-nf:nf,-nf:nf),sub16_3(4),
     . msq36_1(-nf:nf,-nf:nf),sub36_1(4),
     . msq16_4v(-nf:nf,-nf:nf),sub16_4v,
     . msq16_3v(-nf:nf,-nf:nf),sub16_3v,
c     . msq16_2(-nf:nf,-nf:nf),sub16_2(4),
c     . msq26_1(-nf:nf,-nf:nf),sub26_1(4),
c     . msq16_2v(-nf:nf,-nf:nf),sub16_2v,
c     . msq26_1v(-nf:nf,-nf:nf),sub26_1v,
c     . msq15_2v(-nf:nf,-nf:nf),sub15_2v,
c     . msq25_1v(-nf:nf,-nf:nf),sub25_1v,
     . msq16_5v(-nf:nf,-nf:nf),sub16_5v,
     . msq26_5v(-nf:nf,-nf:nf),sub26_5v,
     . msq15_6(-nf:nf,-nf:nf),sub15_6(4),
     . msq25_6(-nf:nf,-nf:nf),sub25_6(4),
     . msq25_6v(-nf:nf,-nf:nf),sub25_6v,
     . msq15_6v(-nf:nf,-nf:nf),sub15_6v,
     . dummyv(-nf:nf,-nf:nf),dsubv
      integer j,k,nd
      double precision oldmass2
      external qg_tbqdk,qg_tbqdk_gvec,donothing_gvec

c--- Note that the subtractions here must separate the initial-final
c--- and final-initial dipoles because of the top/bottom masses
      ndmax=14

      qqproc=.true.
      qgproc=.false.
      gqproc=.false.
      ggproc=.false.

c--- save original value of mass2
      oldmass2=mass2

c--- NOTE: to pass to the "decay" (dk) version of this file, the labels
c---       of the dipoles have not been changed.
c---       For the calls to dips_mass, the momenta
c---       to which they refer will be transformed according to:
c---       3 -> (3+4+5), 4 -> 6, 5 -> 7, 6 -> 8

c--- DIPOLES REQUIRED FOR OFF-DIAGONAL SUBTRACTIONS
c--- subtractions for massless line
      mass2=zip
      call dips_mass(1,p,1,6,5,sub16_5,sub16_5v,msq16_5,msq16_5v,
     . qg_tbqdk,qg_tbqdk_gvec)
      call dips_mass(1,p,5,6,1,sub56_1,dsubv,msq56_1,dummyv,
     . qg_tbqdk,donothing_gvec)

c--- subtractions for massless line
      call dips_mass(2,p,2,6,5,sub26_5,sub26_5v,msq26_5,msq26_5v,
     . qg_tbqdk,qg_tbqdk_gvec)
      call dips_mass(2,p,5,6,2,sub56_2,dsubv,msq56_2,dummyv,
     . qg_tbqdk,donothing_gvec)

      call dips_mass(3,p,1,5,6,sub15_6,sub15_6v,msq15_6,msq15_6v,
     . qg_tbqdk,qg_tbqdk_gvec)
      call dips_mass(4,p,2,5,6,sub25_6,sub25_6v,msq25_6,msq25_6v,
     . qg_tbqdk,qg_tbqdk_gvec)

c--- implement shortcuts for checking
      if ((noglue) .or. (ggonly)) then
      ndmax=4 ! only need the first four dipoles
      else

c--- DIPOLES FOR QG AND QBARG
c--- subtractions for massive line
c--- note: mass of final state particle for final-initial and
c---  final-final dipoles is passed in (clumsily) via mass2
      mass2=mb
      call dips_mass(5,p,2,6,4,sub26_4,sub26_4v,msq26_4,msq26_4v,
     . qg_tbqdk,qg_tbqdk_gvec)
      call dips_mass(6,p,4,6,2,sub46_2,dsubv,msq46_2,dummyv,
     . qg_tbqdk,donothing_gvec)
      mass2=mt
      call dips_mass(7,p,2,6,3,sub26_3,sub26_3v,msq26_3,msq26_3v,
     . qg_tbqdk,qg_tbqdk_gvec)
      call dips_mass(8,p,3,6,2,sub36_2,dsubv,msq36_2,dummyv,
     . qg_tbqdk,donothing_gvec)
      mass2=mt
      call dips_mass(9,p,3,6,4,sub36_4,dsubv,msq36_4,dummyv,
     . qg_tbqdk,donothing_gvec)
      mass2=mb
      call dips_mass(10,p,4,6,3,sub46_3,dsubv,msq46_3,dummyv,
     . qg_tbqdk,donothing_gvec)

c--- EXTRA DIPOLES FOR GQ AND GQBAR
c--- subtractions for massive line
c--- note: mass of final state particle for final-initial and
c---  final-final dipoles is passed in (clumsily) via mass2
      mass2=mb
      call dips_mass(11,p,1,6,4,sub16_4,sub16_4v,msq16_4,msq16_4v,
     . qg_tbqdk,qg_tbqdk_gvec)
      call dips_mass(12,p,4,6,1,sub46_1,dsubv,msq46_1,dummyv,
     . qg_tbqdk,donothing_gvec)
      mass2=mt
      call dips_mass(13,p,1,6,3,sub16_3,sub16_3v,msq16_3,msq16_3v,
     . qg_tbqdk,qg_tbqdk_gvec)
      call dips_mass(14,p,3,6,1,sub36_1,dsubv,msq36_1,dummyv,
     . qg_tbqdk,donothing_gvec)

      endif

c--- reset mass2 to original value
      mass2=oldmass2

      do j=-nf,nf
      do k=-nf,nf
      do nd=1,ndmax
        msq(nd,j,k)=0d0
      enddo
      enddo
      enddo

c--- correction factors to replace the "gsq" that appears in the sub...
c--- expressions with the correct gsq for that line
      corrL=as_L/as
      corrH=as_H/as

c      write(6,*) 'msq(5,2,0)',
c     & msq26_4(2,0),sub26_4(gg),msq26_4v(2,0),sub26_4v

      do j=-4,4
      do k=-4,4

      if ((noglue) .and. (j*k .eq. 0)) goto 99

      if ((ggonly) .and. ((j .ne. 0) .or. (k .ne. 0))) goto 99

      if     ((j .ne. 0) .and. (k .eq. 0)) then
c--- subtractions for qg and qbarg
        msq(1,j,k)=2d0*cf*msq16_5(j,k)*(sub16_5(qq)+sub56_1(qq))*corrL
        msq(5,j,k)=xn*(msq26_4(j,k)*sub26_4(gg)+msq26_4v(j,k)*sub26_4v)
     .               *corrH
        msq(6,j,k)=xn*(msq46_2(j,k)*sub46_2(qq))*corrH
        msq(7,j,k)=xn*(msq26_3(j,k)*sub26_3(gg)+msq26_3v(j,k)*sub26_3v)
     .               *corrH
        msq(8,j,k)=xn*(msq36_2(j,k)*sub36_2(qq))*corrH
        msq(9,j,k)=-(msq36_4(j,k)*sub36_4(qq))/xn*corrH
        msq(10,j,k)=-(msq46_3(j,k)*sub46_3(qq))/xn*corrH
      elseif ((j .eq. 0) .and. (k .ne. 0)) then
c--- subtractions for gq and gqbar
        msq( 2,j,k)=2d0*cf*msq26_5(j,k)*(sub26_5(qq)+sub56_2(qq))*corrL
        msq(11,j,k)=xn*(msq16_4(j,k)*sub16_4(gg)+msq16_4v(j,k)*sub16_4v)
     .                *corrH
        msq(12,j,k)=xn*(msq46_1(j,k)*sub46_1(qq))*corrH
        msq(13,j,k)=xn*(msq16_3(j,k)*sub16_3(gg)+msq16_3v(j,k)*sub16_3v)
     .                *corrH
        msq(14,j,k)=xn*(msq36_1(j,k)*sub36_1(qq))*corrH
        msq( 9,j,k)=-(msq36_4(j,k)*sub36_4(qq))/xn*corrH
        msq(10,j,k)=-(msq46_3(j,k)*sub46_3(qq))/xn*corrH
      elseif ((j .eq. 0) .and. (k .eq. 0)) then
c--- subtractions for gg
       msq(1,j,k)=2d0*tr*(msq16_5(4,k)+msq16_5(3,k)
     .                   +msq16_5(2,k)+msq16_5(1,k))*sub16_5(qg)*corrL
       msq(2,j,k)=2d0*tr*(msq26_5(j,4)+msq26_5(j,3)
     .                   +msq26_5(j,2)+msq26_5(j,1))*sub26_5(qg)*corrL
       msq(3,j,k)=2d0*tr*(msq15_6(-4,k)+msq15_6(-3,k)
     .                   +msq15_6(-2,k)+msq15_6(-1,k))*sub15_6(qg)*corrL
       msq(4,j,k)=2d0*tr*(msq25_6(j,-4)+msq25_6(j,-3)
     .                   +msq25_6(j,-2)+msq25_6(j,-1))*sub25_6(qg)*corrL
      elseif (j*k .lt. 0) then
c--- subtractions for qqbar/qbarq
       msq(1,j,k)=2d0*cf*(msq16_5(0,k)*sub16_5(gq)
     .                   +msq16_5v(0,k)*sub16_5v)*corrH
       msq(2,j,k)=2d0*cf*(msq26_5(j,0)*sub26_5(gq)
     .                   +msq26_5v(j,0)*sub26_5v)*corrH
      elseif (j*k .gt. 0) then
c--- subtractions for qq/qbarqbar
       msq(1,j,k)=(2d0*Vsum(k)-Vsq(-j,k))*cf*(
     &       msq16_5(0,k)*sub16_5(gq)+msq16_5v(0,k)*sub16_5v)*corrH
       msq(2,j,k)=(2d0*Vsum(j)-Vsq(j,-k))*cf*(
     &       msq26_5(j,0)*sub26_5(gq)+msq26_5v(j,0)*sub26_5v)*corrH
       msq(3,j,k)=Vsq(-j,k)*cf*(
     &       msq15_6(0,k)*sub15_6(gq)+msq15_6v(0,k)*sub15_6v)*corrH
       msq(4,j,k)=Vsq(j,-k)*cf*(
     &       msq25_6(j,0)*sub25_6(gq)+msq25_6v(j,0)*sub25_6v)*corrH
      endif

   99 continue

      enddo
      enddo

c      call qg_tbqdk(p,dummyv)
c
c      e25=cf*gsq*(2d0*dot(p,2,5))
c     . /dot(p,2,6)/dot(p,5,6)*dummyv(0,4)
c      e13=xn/2d0*gsq*dummyv(0,4)*(
c     . 2d0*dot(p,1,3)/dot(p,1,6)-mt**2/dot(p,3,6))/dot(p,3,6)
c      e14=xn/2d0*gsq*dummyv(0,4)*(
c     . 2d0*dot(p,1,4)/dot(p,1,6)-mb**2/dot(p,4,6))/dot(p,4,6)
c      e34=-1d0/2d0/xn*gsq*dummyv(0,4)*(
c     . 2d0*dot(p,3,4)/dot(p,3,6)/dot(p,4,6)
c     . -mb**2/dot(p,4,6)**2-mt**2/dot(p,3,6)**2)
c      write(6,*) '(0,4)'
c      write(6,*) 'eikonal 25',e25
c      write(6,*) 'eikonal 13',e13
c      write(6,*) 'eikonal 14',e14
c      write(6,*) 'eikonal 34',e34
c      write(6,*) '   sum    ',e25+e13+e14+e34

c      e15=cf*gsq*(2d0*dot(p,1,5))
c     . /dot(p,1,6)/dot(p,5,6)*dummyv(4,0)
c      e23=xn/2d0*gsq*dummyv(4,0)*(
c     . 2d0*dot(p,2,3)/dot(p,2,6)-mt**2/dot(p,3,6))/dot(p,3,6)
c      e24=xn/2d0*gsq*dummyv(4,0)*(
c     . 2d0*dot(p,2,4)/dot(p,2,6)-mb**2/dot(p,4,6))/dot(p,4,6)
c      e34=-1d0/2d0/xn*gsq*dummyv(4,0)*(
c     . 2d0*dot(p,3,4)/dot(p,3,6)/dot(p,4,6)
c     . -mb**2/dot(p,4,6)**2-mt**2/dot(p,3,6)**2)
c      write(6,*) '(4,0)'
c      write(6,*) 'eikonal 15',e15
c      write(6,*) 'eikonal 23',e23
c      write(6,*) 'eikonal 24',e24
c      write(6,*) 'eikonal 34',e34
c      write(6,*) '   sum    ',e15+e23+e24+e34

      return
      end