!!  wrt a BC parameter such as freestream velocity or inlet total temperature defined the user.
!!  This is an adjoint-based procedure, as such it needs both a primal solution and an adjoint
!!  solution.
!!  As a ChiDG action it requires one or two arguments: ONE if the file provided contains both
!!  the primal and adjoint solution, TWO files if primal and adjoint solution are store in two
!!  separate files. Notice that the grid information have to be in the first file provided,
!!  that is the primal solution.
!!
!!  @author Matteo Ugolotti
!!  @date 11/26/2018
!!
!!
!!  Usage: chidg adjointbc
!!
!
!----------------------------------------------------------------------------------------------
module mod_chidg_adjointbc
#include <messenger.h>
    use mod_kinds,                  only: rk, ik
    use type_chidg,                 only: chidg_t
    use mod_chidg_mpi,              only: GLOBAL_MASTER, ChiDG_COMM, IRANK, NRANK
    use type_svector,               only: svector_t
    use mod_string,                 only: string_t, get_file_prefix, check_file_extension
    use type_file_properties,       only: file_properties_t
    use mod_hdf_utilities,          only: get_properties_hdf
    use mod_file_utilities,         only: delete_file
    use mod_io
    implicit none

contains

    !>  Driver for computing the sensitivities of an objective function wrt BC parameters
    !!
    !!  @author Matteo Ugolotti
    !!  @date 11/26/2018
    !!
    !!  Required computation
    !!
    !!      DJ/Da = dJ/da + v^T*dR/da
    !!
    !!      where "a" is the BC parameter
    !!
    !------------------------------------------------------------------------------------------
    subroutine chidg_adjointbc()

        type(chidg_t)                               :: chidg
        integer(ik)                                 :: ierr, ifile_f, ifile_a, istep, nfunctionals, &
                                                       iproc, msg, unit
        character(len=:),               allocatable :: usr_msg, tmp_flow_file, tmp_adj_file,    &
                                                       command_flow, command_adj, flow_prefix,  &
                                                       adj_prefix, flow_solution_files,         &
                                                       adjoint_solution_files
        character(len=1024)                         :: flow_solution_file, adjoint_solution_file
        type(svector_t)                             :: flow_files, adjoint_files, bc_params
        type(string_t)                              :: str_flow, str_adj, bc_param_str, bc_group_str
        type(file_properties_t)                     :: file_props
        logical                                     :: solutions_mismatch, nsteps_mismatch, file_exists, &
                                                       hdf_file
        character(len=100)                          :: bc_property, bc_group

        ! Define namelist for BC parameter (This has to be on top of the subroutine)
        namelist /bc_param/    bc_group, bc_property

        ! Initialize ChiDG environment
        call chidg%start_up('mpi')
        call chidg%start_up('namelist')
        call chidg%start_up('core')

        ! Work out wildcards
        flow_prefix = get_file_prefix(solutionfile_in,'.h5')
        flow_solution_files = trim(flow_prefix)//'*'
        adj_prefix = get_file_prefix(adjointfile_out,'.h5')
        adjoint_solution_files = trim(adj_prefix)//'*'

        tmp_flow_file = 'chidg_adjointbc_flow_files.txt'
        tmp_adj_file  = 'chidg_adjointbc_adj_files.txt'
        if (IRANK == GLOBAL_MASTER) then
            command_flow  = 'ls '//trim(flow_solution_files)   //' > '//tmp_flow_file
            command_adj   = 'ls '//trim(adjoint_solution_files)//' > '//tmp_adj_file
            call system(command_flow)
            call system(command_adj)
        end if

        ! Save all files in svector
        do iproc = 0,NRANK-1
            if (iproc == IRANK) then
                open(7,file=tmp_flow_file,action='read')
                do
                    read(7,fmt='(a)', iostat=ierr) flow_solution_file
                    if (ierr /= 0) exit
                    hdf_file = check_file_extension(trim(flow_solution_file),'.h5')
                    if (hdf_file) then
                        call str_flow%set(trim(flow_solution_file))
                        call flow_files%push_back(str_flow)
                    end if
                end do
                close(7)
                open(8,file=tmp_adj_file,action='read')
                do
                    read(8,fmt='(a)', iostat=ierr) adjoint_solution_file
                    if (ierr /= 0) exit
                    hdf_file = check_file_extension(trim(adjoint_solution_file),'.h5')
                    if (hdf_file) then
                        call str_adj%set(trim(adjoint_solution_file))
                        call adjoint_files%push_back(str_adj)
                    end if
                end do
                close(8)
            end if
            call MPI_Barrier(ChiDG_COMM,ierr)
        end do

        ! Check that the number of primal solutions is equal to number of adjoint solutions
        solutions_mismatch = ( flow_files%size() /= adjoint_files%size() )
        if (solutions_mismatch) then
            call chidg_signal(FATAL,'The number of primal solutions does not match the number of adjoint solutions read in. Make sure that all the files containing the primal and dual solutions are present in the folder. Also check that the file names provided as input argument to ChiDG AdjointBC are correct. ')
        end if

        ! Check if input from 'parameter.nml' is available.
        !   1: if available, read and set
        !   2: if not available, return error. The file must be there
        inquire(file='parameters.nml', exist=file_exists)
        if (file_exists) then
            open(newunit=unit,form='formatted',file='parameters.nml')
            read(unit,nml=bc_param,iostat=msg)
            if (msg /= 0) call chidg_signal(FATAL,"read_input: error reading 'bc_param' namelist from 'parameters.nml'.")
            close(unit)

            ! Add parameter to a svector
            call bc_group_str%set(trim(bc_group))
            call bc_param_str%set(trim(bc_property))
            call bc_params%push_back(bc_group_str)
            call bc_params%push_back(bc_param_str)

        else
            call chidg_signal(FATAL,"'parameters.nml' file is missing. Please, specify the BC parameter in the namelist file.")
        end if

        ! Set ChiDG Algorithms, Accuracy
        ! TODO: this might not be necessary
        call chidg%set('Time Integrator' , algorithm=time_integrator                    )
        call chidg%set('Nonlinear Solver', algorithm=nonlinear_solver, options=noptions ) ! not used
        call chidg%set('Linear Solver'   , algorithm=linear_solver,    options=loptions ) ! not used
        call chidg%set('Preconditioner'  , algorithm=preconditioner                     ) ! not used
        call chidg%set('Solution Order'  , integer_input=solution_order                 )

        call MPI_Barrier(ChiDG_COMM,ierr)

        ! Theoretically, the number of files should be equal to the number of time steps (nsteps)
        ! defined in the namelist as time_steps
        ! Check that this is true. q_time hs been initialized with the number of steps defined
        ! in the namelist like all the other containers for adjoint and adjointbc.
        nsteps_mismatch = ( (flow_files%size() /= time_steps) .or. (adjoint_files%size() /= time_steps) )
        if (nsteps_mismatch) then
            call chidg_signal(FATAL,'The number of primal or adjoint solutions does not match the number of time steps defined in the namelist. Please, make sure all the files are located in the current folder or that the time_steps input in the namelist is correct.')
        end if

        ! Read grid from solution_file, boundary condition data and functionals
        ! The assumption here is that the primal solver has been run already with functionals
        ! selected or edited (chidg edit) for adding functionals.
        call chidg%read_mesh(flow_files%data_(1)%get(), storage='adjointbc storage')

        ! Read primal solution/s
        do ifile_f = 1,flow_files%size()

            ! Get necessary file properties
            do iproc = 0,NRANK-1
                if (iproc == IRANK) then
                    file_props  = get_properties_hdf(flow_files%data_(ifile_f)%get())
                    istep       = file_props%istep
                end if
                call MPI_Barrier(ChiDG_COMM,ierr)
            end do

            ! Read in primal solution
            call chidg%read_fields(flow_files%data_(ifile_f)%get(),'primary')

            ! Copy primal solution from sdata%q_in to adjoint%q_time(:)
            call chidg%data%sdata%adjoint%process_primal_solution(chidg%data%sdata%q_in,istep)

        end do

        ! Read adjoint solution/s
        do ifile_a = 1,adjoint_files%size()

            ! Get necessary file properties
            do iproc = 0,NRANK-1
                if (iproc == IRANK) then
                    file_props   = get_properties_hdf(adjoint_files%data_(ifile_a)%get())
                    istep        = file_props%istep
                    nfunctionals = file_props%nfunctionals
                end if
                call MPI_Barrier(ChiDG_COMM,ierr)
            end do

            ! Set adjoint fields and read in adjoint solution
            call chidg%data%set_fields_adjoint(nfunctionals)
            call chidg%read_fields(adjoint_files%data_(ifile_a)%get(),'adjoint')

            ! Copy adjoint solution vector from adjoint%v_in to adjoint%v
            call chidg%data%sdata%adjoint%process_adjoint_solution(istep)

        end do

        ! Reset fields so that Rx and Jx can be computed correctly.
        ! That is, remove adjoint fields.
        call chidg%data%reset_fields()

        ! Compute mesh sensitivities
        call chidg%reporter('before')
        call chidg%run_adjointbc(bc_params,write_final=.true.)
        call chidg%reporter('after')

        ! Close ChiDG
        call chidg%shut_down('core')
        call chidg%shut_down('mpi')

        ! Delete tmp files
        if (IRANK == GLOBAL_MASTER) call delete_file(tmp_flow_file)
        if (IRANK == GLOBAL_MASTER) call delete_file(tmp_adj_file)

    end subroutine chidg_adjointbc
    !******************************************************************************************

end module mod_chidg_adjointbc


c
c  this program filters converts the patran compatible WARP result file
c  to TECPLOT loadable data file
c
c
      program tecplot_patran
      implicit integer (a-z)
      parameter(n_max=500)
      parameter(num_node=95000)
      parameter(num_elem=50000)
      parameter(maxcols=26)
c
      common   /text/ textstring
c
      double precision ux(num_node), uy(num_node), uz(num_node)
      double precision x(3, num_node), elval(maxcols, num_elem)
      real xval, yval, zval, pvals(maxcols), rtemp
      character*9 ch_disp(n_max), ch_strn(n_max), ch_strs(n_max)
      character*12  dispfile(n_max), stressfile(n_max),
     &     strainfile(n_max)
      character binnam*80, ok*1, cstep*6, yes*6, strsname*80, struc*30,
     &          strnname*80
      character textstring*80, coordinates*30, incidences*30, dispname*12
      dimension title(80), ele(20, num_elem)
      dimension nstep(n_max), ino(num_node), iel(num_elem),
     &          lex(num_elem)
c
c
c
c--------------------------------------
c
      write(*,*)
      write(*,*)' --------------------------------------------------'
      write(*,*)'| Program prepares data for Tecplot 360 program    |'
      write(*,*)'|                                                  |'
      write(*,*)'| The input files is: web* wnb*                    |'
      write(*,*)'| The output files are: disp*.dat strs*.dat        |'
      write(*,*)'|                       and strn*.dat              |'
      write(*,*)'|                                                  |'
      write(*,*)'|                                                  |'
      write(*,*)'| Computational Fracture Mechanics Research Group  |'
      write(*,*)'| University of Illinois at Urbana-Champaign       |'
      write(*,*)'|                                                  |'
      write(*,*)'| Last modification: June  18, 2007                |'
      write(*,*)' --------------------------------------------------'
      write(*,*)
c
c--------------------------------------
c
c
      write(*,*) 'How many steps at which warp result files exist?'
      read(*,*) nn
      write(*,*) 'For every ? steps the results were output?'
      read(*,*) nk
3     write(*,*) 'nodal stress or strain (s for stress, n for strain)?'
      read(*,'(a)') ok
         if(ok.ne.'s'.and.ok.ne.'S'.and.ok.ne.'n'
     &   .and.ok.ne.'N') then
          write(*,*) 'please enter "s" for stress or "n" for strain'
          go to 3
         endif
         write(*,*) 'output for nodal displacement, (yes or no)?'
         read(*,'(a)') yes
      write(*,*) 'Total element number in the model?'
      read(*,*) nelem
      write(*,*) 'Total node number in the model?'
      read(*,*) n_nod
         write(*,*) 'prefix of the input file?'
         read(*,'(a)') struc
5        write(*,*) '8 or 20 node elements?'
         read(*,*) ncon
c
         if(ncon.ne.8.and.ncon.ne.20)then
          write(*,*) 'please enter 8 or 20!'
          go to 5
         endif
c
c
      do i=1,nn
      nstep(i) = nk*i
      write(cstep, 100) nstep(i)
      ch_disp(i)='wnbd'//cstep(2:6)
      dispfile(i)='disp'//cstep(3:6)//'.dat'
      stressfile(i)='strs'//cstep(3:6)//'.dat'
      strainfile(i)='strn'//cstep(3:6)//'.dat'
       ch_strn(i)='wnbe'//cstep(2:6)
       ch_strs(i)='wnbs'//cstep(2:6)
      enddo
100   format('c',i5.5)
c
c   Read in the nodal coordinates and element connectivity
c
      textstring=struc//'   '
      call left_centred(30,irp)
      struc=textstring(1:30)
      il=1
10       il=il+1
      if (il.lt.irp) then
      if (struc(il:il).ne.'.') goto 10
      il=il-1
      endif
c
      coordinates = struc(1:il)//'.crd'
      incidences = struc(1:il)//'.elm'
c
      open(unit=1,file=coordinates,status='old')
      do i=1,n_nod
          read(1,*) ii, x(1,ii), x(2,ii), x(3,ii)
         enddo
         close(unit=1)
      open(unit=1,file=incidences,status='old')
      do i=1,nelem
          if(ncon.eq.8)then
          read(1,*) ii, ele(1,ii), ele(2,ii), ele(3,ii), ele(4, ii),
     &  ele(5, ii), ele(6, ii), ele(7, ii), ele(8,ii)
          else
          read(1,*) ii, ele(1,ii), ele(2,ii), ele(3,ii), ele(4, ii),
     &  ele(5, ii), ele(6, ii), ele(7, ii), ele(8,ii), ele(9,ii),
     &  ele(10,ii), ele(11,ii), ele(12,ii), ele(13,ii), ele(14,ii),
     &  ele(15,ii), ele(16,ii), ele(17,ii), ele(18,ii), ele(19,ii),
     &  ele(20, ii)
          endif
         enddo
         close(unit=1)
c
c *********************************************************
c *                                                       *
c *    read displacement binary patran file               *
c *                                                       *
c *********************************************************
c
      if((yes(1:1).eq.'y').or.(yes(1:1).eq.'Y')) then
c
      termin=5
      termot=6
      binfil=10
         tec=15
c
      write(termot,*) ' '
      write(termot,*) ' '
      write(termot,*) '>> binary node value processing program'
      write(termot,*) ' '
c
      do 200 i=1,nn
      open(unit=tec,file=dispfile(i),status='unknown')
         write(tec,*) 'Variables= "X", "Y","Z", "Node UserID",
     &"U", "V", "W","Step ID"'
         write(tec,*) 'Zone T="nodaldisp", N=', n_nod,',','E=',nelem,','
     &  ,'datapacking=point, zonetype=FEBRICK'
       binnam = ch_disp(i)
       open(unit=binfil,file=binnam,status='old',recl=3000,
     &      form='unformatted')
      write(termot,*) ' '
      write(termot,'(a,a,a)') ' > file ', ch_disp(i), ' open ok'
c
c           read the binary results file of nodal values.
c           read x, y, z components. patran results are single
c           precision. read as single and store as double.
c
      read(binfil) title, nnode, ii, rtemp, ii, nvals
      read(binfil) title
      read(binfil) title
c
c            read values for each node into a double array
c
      write(termot,*) '> reading nodal results file..'
      do node = 1,nnode
        read(binfil) ii, xval, yval, zval
        ux(node) = xval
       uy(node) = yval
       uz(node) = zval
       ino(node) = ii
c
      if(ii.ne.node) then
       write(*,*) 'error during reading nodal results !!!'
       stop
      endif
c
c => n_step  node-number  u1   u2   u3
      write(tec,150)  x(1,node), x(2,node),x(3,node),
     & ino(node), ux(node), uy(node), uz(node),nstep(i)
      enddo
150   format(3(2x,g15.6),(2x,i6),3(2x,g15.6),(2x,i6))
         do elem=1, nelem
         write(tec, 180) (ele(ii,elem), ii=1,8)
         enddo
180   format(8(2x,i6))
      close(unit=tec)
      close(unit=binfil)
      write(termot,*) '> writing nodal results to file..'
200   continue
      endif
c
c ************************************************************
c *                                                          *
c *  Read in stress strain  binary patran files              *
c *                                                          *
c ************************************************************
c
      write(termot,*) ' '
      write(termot,*) ' '
      write(termot,*) '>> binary stress/strain processing program'
      write(termot,*) ' '
c
      if((ok(1:1).eq.'s') .or. (ok(1:1).eq.'S')) then
      do 300 i=1,nn
      binnam = ch_strs(i)
      strsname=stressfile(i)
      open(unit=tec,file=strsname,status='unknown')
      write(tec,*) 'Variables="X","Y","Z", "NodeID"'
      write(tec,*) '"Sxx","Syy","Szz","Sxy","Syz","Sxz",'
      write(tec,*) '"U0","mises", "c1", "c2", "c3", "I1", "I2","I3",'
      write(tec,*) ' "S1","S2","S3","l1","m1","n1","l2","m2","n2", '
          write(tec,*) '"l3","m3","n3","Step ID"'
          write(tec,*) 'Zone T="nodalstress", N=', n_nod, 'E=',nelem,
     & 'datapacking=point, zonetype=FEBRICK'
       write(*,*)'Processing file: ',binnam
       open(unit=binfil,file=binnam,status='old',recl=3000,
     &     form='unformatted')
      write(termot,*) ' '
      write(termot,'(a,a,a)') ' > file ', ch_strs(i), ' open ok'
c
c           read the binary results file of nodal strains/stresses.
c           patran results are single precision. read as single and
c           store as double.
c
      read(binfil) title, nnode, ii, rtemp, ii, nvals
      read(binfil) title
      read(binfil) title
c
c            read values for each node into a double array
c
      write(termot,*) '> reading nodal stress/strain file..'
      write(termot,*) '> writing nodal stress/strain to file..'
c
c
      do node = 1,nnode
       read(binfil) ii, (pvals(jj),jj=1,nvals)
       ino(node) = ii
      if(ii.ne.node) then
       write(*,*) 'error during reading nodal results !!!'
       stop
      endif
c
      write(tec,250) x(1,node), x(2,node),x(3,node),
     &  ino(node),(pvals(jj),jj=1,nvals),nstep(i)
c
      enddo
250   format(3(2x,g15.6)(2x,i6),26(2x,g15.6),(2x,i6))
      close(unit=binfil)
         do elem=1, nelem
         write(tec, 280) (ele(ii,elem), ii=1,8)
         enddo
280   format(8(2x,i6))
      close(unit=tec)
c
300   continue
c
      else
c
      do 400 i=1,nn
      binnam = ch_strn(i)
      strnname=strainfile(i)
      open(unit=tec,file=strnname,status='unknown')
      write(tec,*) 'Variables="X","Y","Z","NodeID",'
      write(tec,*) '"Exx","Eyy","Ezz","Exy","Eyz","Exz","Eeff",'
      write(tec,*) '"I1", "I2", "I3", "e1", "e2", "e3","l1","m1",'
      write(tec,*) '"n1","l2","m2","n2","l3","m3","n3", "STEP ID"'
          write(tec,*) 'Zone T="nodestrain", N=',n_nod,'E=',nelem,
     & 'datapacking=point, zonetype=FEBRICK'
      write(*,*)'Processing file: ',binnam
      open(unit=binfil,file=binnam,status='old',recl=3000,
     &     form='unformatted')
      write(termot,*) ' '
      write(termot,'(a,a,a)') ' > file ', ch_strn(i), ' open ok'
c
c           read the binary results file of nodal strains/stresses.
c           patran results are single precision. read as single and
c           store as double.
c
      read(binfil) title, nnode, ii, rtemp, ii, nvals
      read(binfil) title
      read(binfil) title
c
c            read values for each node into a double array
c
      write(termot,*) '> reading nodal stress/strain file..'
      write(termot,*) '> writing nodal stress/strain to file..'
c
c
      do node = 1,nnode
        read(binfil) ii, (pvals(jj),jj=1,nvals)
        ino(node) = ii
      if(ii.ne.node) then
       write(*,*) 'error during reading nodal results !!!'
       stop
      endif
c
      write(tec,350) x(1,node), x(2,node),x(3,node),
     &  ino(node),(pvals(jj),jj=1,nvals),nstep(i)
c
      enddo
350   format(3(2x,g15.6),(2x,i6),22(2x,g15.6),(2x,i6))
      close(unit=binfil)
         do elem=1, nelem
         write(tec, 380) (ele(ii,elem), ii=1,8)
         enddo
380   format(8(2x,i6))
      close(unit=tec)
c
400   continue
      endif
c
         stop
         end
c
c ********************************************************************
c
c     this subroutine rewrites the string from the first non-empty
c     letter to the last letter, and also gives the total number of
c     letters in the string
c
c ********************************************************************
c----67--1---------2---------3---------4---------5---------6---------7-!
      subroutine left_centred(nch,rpo)
      implicit none
c
      integer   nch,rpo,l,r,i
      character textstring*80
c
      common   /text/ textstring
c
      l=0
10    l=l+1
      if ( textstring(l:l).eq.' ') goto 10
      r=l
20    r=r+1
      if (r.lt.nch) then
        if (textstring(r:r).ne.' ') goto 20
        r=r-1
      endif
      rpo=0
      do i=l, r
        rpo=rpo+1
        textstring(rpo:rpo)=textstring(i:i)
      enddo
      return
      end
c


C    %W% %G%
      subroutine deriv

C     This subroutine is the calling routine for the network
C     solution.  It calls the various subroutines needed to calculate
C     the injected current vector and then calls the routines needed
C     to obtain a new network solution.  It is called by CNTRL.  It
C     calls DCLIN, DWNBAK, GENCUR, GENUPD, KEYBRD, LODCUR, MDCLIN, new
C     PRTERR, PRTOUT, REDUC1, XTIME, and ZNOSOL.

      include 'tspinc/params.inc'
      include 'tspinc/blkcom1.inc'
      include 'tspinc/buslod.inc'
      include 'tspinc/igentn.inc'
      include 'tspinc/bname.inc'
      include 'tspinc/buskv.inc'
      include 'tspinc/machd2.inc'
      include 'tspinc/ldcc.inc'
      include 'tspinc/cntrl2.inc'
      include 'tspinc/param.inc'
      include 'tspinc/contrl.inc'
      include 'tspinc/prt.inc'
      include 'tspinc/search.inc'
      include 'tspinc/lnk12.inc'
      include 'tspinc/lnk12a.inc'
      include 'tspinc/link2.inc'
      include 'tspinc/lnk1a.inc'
      include 'tspinc/vrgov.inc'
      include 'tspinc/ecsind.inc'
      include 'tspinc/equiv.inc'
      include 'tspinc/brake1.inc'
      include 'tspinc/ectba.inc'
      include 'tspinc/mdctbl.inc'
      include 'tspinc/dcblk.inc'
      include 'tspinc/ecstbb.inc'
      include 'tspinc/ecstbh.inc'
      include 'tspinc/pointr.inc'
      include 'tspinc/delcr.inc'
      include 'tspinc/ecstbj.inc'
      include 'tspinc/bcur.inc'
      include 'tspinc/busvolt.inc'
      include 'tspinc/znox.inc'
      include 'tspinc/newton.inc'
      include 'tspinc/fltopt.inc'
      include 'tspinc/iter.inc'
      include 'tspinc/lowzno.inc'
      include 'tspinc/deltfq.inc'

      common /mytr/mytr
      common /satsw/satsw

      character*8 gname, busnam
      character*1 gid
      character*8 name

      call xtime(4)

C     Values of IILOCF and IINDXZ are offset to reflect relative
C     locations of ILOCFT and INDXZ in /ECSTBJ/

      iilocf = 1
      iindxz = 1
      nmxt = nmx
      if (iesc .ne. 1) nmxt = nmx
      iter = 1
      ido = 1
      i5065 = 1
      idvrg = 1
      dresid = 999999.0
      dsum = 0.0
      icur = 0
      imcur = 0
      imax = 1
      zero = 0.0

C     YISOLN, NEWTON option

C     setup code: IIDSW7 =  1 -> bypass reduce
C     IIDSW7 =  2 -> xeq reduce

      do while (.true.)
        if (idsw .eq. 7 .and. iter .eq. 1) then
          iidsw7 = 1
        else
          iidsw7 = 2
        endif

C       New timestep and first itereration

        if (lppwr .eq. 0 .and. iter .eq. 1) then
          newdt = 1
        else
          newdt = 2
        endif

C       Newton or Y-matrix solution option

        if (iidsw7 .eq. 1 .or. idsw .ne. 7 .and. newdt .eq. 1) then
          mdeyoj = 1
        else
          mdeyoj = 2
        endif
        cmax = 0.0

C       Call GENCUR to calculate current injections at the machines

        call gencur()

C       IPWR = 1 means all loads are constant impedance, so skip
C       load current injection calculations

        if (ipwr .ne. 1) then

C         If ITER=1 and LPPWR=0 set all loads to constant impedance

          if (iter .eq. 1 .and. lppwr .eq. 0) then
            cmax = 10.0
            do i = 1, nmx
              delcr(i) = 0.0
            enddo
          else

C           Call LODCUR to calculate load current injection estimate

            call lodcur()
            goto 100
          endif
        endif

C       Call ZNOSOL to find equivalent admittance of zno capacitor

        do i = 1, nmx
          bcurr(i) = 0.0
          bcuri(i) = 0.0
        enddo
  100   if (iznmax .gt. 0) call znosol()

C       Call DCLIN to solve two terminal dc line equations

        call xtime(-4)
        call xtime(7)
        if (ldc .ne. 0) call dclin(iter)

C       Call MDCLIN to solve multi-terminal dc line logic

        if (ldc1 .ne. 0) then
          ldcc = 1
          jecs1 = kdc1
          do while (.true.)
            if (mdcblk(ldcc) .ne. 1) then
              call redecs(dcb, jecs1, msizeb)
              if (iter .eq. 1) then
                if (lppwr .eq. 0) then

C                 Initialize delta curr storage

                  do i = 1, nterm
                    i1 = lbt + i
                    call ritecs(zero, idcb(i1)+40, 1)
                  enddo
                  if (ldc .eq. 0) cmax = 10.0
                  if (idsw .ne. 7) then

C                   Process commutation voltage

                    do i = 1, nterm
                      i1 = lbt + i
                      call redecs(ecn, idcb(i1)+41, 1)
                      call ritecs(ecn, idcb(i1)+42, 1)
                    enddo
                  endif
                endif
              endif

C             Call MDCLIN to solve dc multiterminal line equations

              call mdclin(iter)
              if (link .gt. 10) goto 190

C             Store last dc calculation

              call ritecs(dcb, jecs1, ndimc)
            endif

C           Tally multi-terminal dc counter

            ldcc = ldcc + 1
            if (ldcc .gt. ldc1) goto 110
            jecs1 = kdcm(ldcc)
          enddo
        endif
  110   call xtime(-7)
        call xtime(4)

C       BUSP and BUSQ temporarily hold the load injection currents, but
C       ulitmately will contain bus load in WRTHIS

        do itrr = 1, nmx
          busp(itrr) = bcurr(itrr)
          busq(itrr) = bcuri(itrr)
        enddo

C       Add current injection from generators to current vector

        do i = 1, isg
          i1 = igentn(1, i)
          bcurr(i1) = bcurr(i1) + eyri(i)
          bcuri(i1) = bcuri(i1) + eyii(i)
        enddo
        if (keybrd(13) .ne. 0) then
          write (outbuf, 10000) iter
10000     format (' 0  CURRENT AT S1260 ITER, EYR AND EYI', i10)
          call prtout(1)
          do i1 = 1, nmx, 4
            k = i1 + 3
            do jjj = i1, k, 8
              kkk = min0(jjj+7, k)
              write (outbuf, 10010) i1, (bcurr(j), bcuri(j), j = jjj,
     &         kkk)
10010         format (1x, i4, 8e13.6)
              call prtout(1)
            enddo
          enddo
        endif

C       YISOLN, NEWTON option

        if (inewts .eq. 2) then

C         Newtons method solution

          if (iidsw7 .ne. 1) then

C           NEWDT = 1 means the first iteration for a time step which uses
C           the admittance matrix, so call REDUCE to factorize the Y-matrix.
C           NEWDT = 2 means use Newtons method for the remaining iterations,
C           so call NEWTSL to obtain the nework solution.

            if (newdt .eq. 2) then
              call newtsl()
              goto 120
            else
              lfrst = 1
              nordk = 1
              call reduc1()
            endif
          endif

C       Admittance matrix solution

        elseif (ncomp .ne. 0) then
          if (iidsw7 .ne. 1) then

C           Test if Y-matrix needs to be factorized

            if (lowzno .ne. nmx+1) then
              lfrst = lowzno
              if (ido .eq. 2) then
                ido = 1
              else
                nordk = 1
                call reduc1()
              endif
            endif
          endif
        endif
        call xtime(-4)
        call xtime(6)

C       Call DWNBAK to obtain new voltage vector

        call dwnbak()
        call xtime(-6)
        call xtime(4)
  120   if (keybrd(11) .ne. 0) then
          write (outbuf, 10020)
10020     format ('0', 10x, 'volts')
          call prtout(1)
          do i1 = 1, nmx, 4
            k = i1 + 3
            do jjj = i1, k, 8
              kkk = min0(jjj+7, k)
              write (outbuf, 10010) i1, (eyr(j), eyi(j), j = jjj, kkk)
              call prtout(1)
            enddo
          enddo
        endif

C       If all machines are classical and all loads constant z
C       there is no need to iterate

        if (igtmax .eq. 1 .and. ipwr .eq. 1) goto 160

C       Test for tolerance in network solution

        if (idsw .eq. 7) then
          if (iter .ne. 1) then
            if (cmax .le. toli) goto 130
          endif

C         NCHCK = 1 means this is the initial solution so check for
C         divergence after 3 iterations

          if (nchck .ne. 2) then
            if (iter .le. 3) then
              dresid = dsum
            elseif (dresid .ge. dsum) then
              dresid = dsum
            else
              goto 150
            endif
          endif
          if (keybrd(15) .ne. 0 .or. nchek .eq. 1) then
            if (imax .gt. nmx) then
              igi = imax - nmx
              ibs = igentn(1, igi)
              gname = bname(ibs)
              gid = igentc(igi)
              gkv = buskv(ibs)
              write (outbuf, 10030) gname, gid, gkv, igi, cmax, iter,
     &         dsum
10030         format (' *$JA,K15-GEN ', a8, a1, f6.1, 'KV', i5, ' IGI',
     &         f12.6, ' DELTA I', i3, ' ITER', f12.4, ' ABSUM')
              call prtout(1)
            else
              busnam = bname(imax)
              bkv = buskv(imax)
              write (outbuf, 10040) busnam, bkv, imax, cmax, iter, dsum
10040         format (' *$JA,K15-BUS ', a8, 1x, f6.1, 'KV', i5, 'IBUS',
     &         f12.6, ' DELTA I', i3, ' ITER', f12.4, ' ABSUM')
              call prtout(1)
            endif
          endif

C         Test for iteration limit

          if (iter .lt. ilim) then
            iter = iter + 1
            goto 140
          endif

  130     if (keybrd(14) .ne. 0) then
            if (imax .gt. nmx) then
              igi = imax - nmx
              ibs = igentn(1, igi)
              gname = bname(ibs)
              gid = igentc(igi)
              gkv = buskv(ibs)
              write (outbuf, 10050) gname, gid, gkv, igi, cmax, iter,
     &         dsum
10050         format (' *$JA,K14-GEN ', a8, a1, f8.1, 'KV', i5, 'IGI',
     &         f12.6, ' DELTA I', i3, ' ITER', f12.4, ' ABSUM')
              call prtout(1)
            else
              busnam = bname(imax)
              bkv = buskv(imax)
              write (outbuf, 10060) busnam, bkv, imax, cmax, iter, dsum
10060         format (' *$JA,K14- BUS ', a8, f8.1, 'KV', i6, 'IBUS',
     &         f12.6, ' DELTA I', i3, ' ITER', f12.4, ' ABSUM')
              call prtout(1)
            endif
          endif
        endif

C       Convergence within network tolerance has been satisfied

        if (nchck .eq. 2) goto 180
        if (.not. (cmax .gt. 0.001 .and. iter .le. 15)) goto 170
        iter = iter + 1
  140   continue
      enddo
  150 write (errbuf(1), 10070)
10070 format ('Divergence on inititial balance')
      call prterr('E', 1)
      link = 13
      call xtime(-4)
      goto 190
  160 if (nchck .ne. 1) goto 180

C     Initial solution (t = 0.0-)

C     Compare swing voltage with power flow voltage (node 2 only)
C     at initial network solution

  170 a1 = abs(esoln-eyr(2)) + abs(fsoln-eyi(2))
      if (a1 .ge. 0.002) then
        write (errbuf(1), 10080)
10080   format (
     &   '0Unsuccessful initialization - Network voltages do not match P
     &owerflow voltages'
     &   )
        call prterr('E', 1)
        write (outbuf, 10090) esoln, fsoln, eyr(1), eyi(1)
10090   format (1x, 2f12.6, 'calc v', 2f12.6, 'soln v')
        call prtout(1)
        link = 13
        call xtime(-4)
        call erexit()
        goto 190
      else
        write (outbuf, 10100) nmx, mytr
10100   format (
     &   '0Successful initialization - commence with swing .... ', i4,
     &   ' buses', 5x, i6, ' off-diag')
        call prtout(1)

C       Set TX, LD saturation SW = 1.0

        satsw = 1.0
        if (iter .gt. 2) then
          write (errbuf(1), 10110)
10110     format ('0 Error in initial network solution: zero minus ',
     &     'network solution is taking more than two iterations.')
          write (errbuf(2), 10120)
10120     format ('  This may be an error condition.')
          call prterr('W', 2)
        endif
      endif

C     Call GENUPD to update generator power and terminal voltage
C     following a network iteration

  180 call genupd()
      call xtime(-4)
  190 return
      end


      FUNCTION IUPB(MBAY,NBYT,NBIT)

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    IUPB
C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
C
C ABSTRACT: THIS FUNCTION UNPACKS AND RETURNS A BINARY INTEGER WORD
C   CONTAINED WITHIN NBIT BITS OF A BUFR MESSAGE PACKED INTO THE
C   INTEGER ARRAY MBAY, STARTING WITH THE FIRST BIT OF BYTE NBYT.
C
C PROGRAM HISTORY LOG:
C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C                           INTERDEPENDENCIES
C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY
C                           DOCUMENTATION
C
C USAGE:    IUPB (MBAY, NBYT, NBIT)
C   INPUT ARGUMENT LIST:
C     MBAY     - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR
C                MESSAGE
C     NBYT     - INTEGER: BYTE WITHIN MBAY AT WHOSE FIRST BIT TO BEGIN
C                UNPACKING
C     NBIT     - INTEGER: NUMBER OF BITS WITHIN MBAY TO BE UNPACKED
C
C   OUTPUT ARGUMENT LIST:
C     IUPB     - INTEGER: UNPACKED INTEGER WORD
C
C REMARKS:
C    THIS ROUTINE CALLS:        UPB
C    THIS ROUTINE IS CALLED BY: CKTABA   CPYUPD   GETLENS  IUPBS01
C                               IUPBS3   MSGUPD   MSGWRT   RDMEMS
C                               STNDRD   STRCPT   SUBUPD   UPDS3
C                               WRITLC
C                               Normally not called by any application
C                               programs.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  PORTABLE TO ALL PLATFORMS
C
C$$$

      DIMENSION MBAY(*)

C----------------------------------------------------------------------
C----------------------------------------------------------------------

      MBIT = (NBYT-1)*8
      CALL UPB(IRET,NBIT,MBAY,MBIT)
      IUPB = IRET
      RETURN
      END


      SUBROUTINE ALG19 (LOG1,LOG2,LOG3,LOG5,NLINES,NSPEC,KPTS,RSTA,
     1                  XSTA,R,ZR,B1,B2,TC,PI,C1,NBLADE,CCORD,BLOCK,
     2                  ALPB,EPSLON,IFANGS,IPUNCH,NAERO)
C
      DIMENSION       IDATA(24),RDATA(6),KPTS(1),RSTA(21,10),
     1                XSTA(21,10),R(10,21),ZR(1),B1(1),B2(1),TC(1),
     2                CCORD(1),BLOCK(10,21),ALPB(10,21),EPSLON(10,21),
     3                NR(10),NTERP(10),NMACH(10),NLOSS(10),NL1(10),
     4                NL2(10),NEVAL(10),NCURVE(10),NLITER(10),NDEL(10),
     5                RR(21,10),XLOSS(21,10),RTE(5),DM(11,5),
     6                DVFRAC(11,5),RDTE(21),DELTAD(21),AC(21),F137B(8),
     7                F137S(5),F142TC(7),F161D(8,5),F195M(8,2),F164XB(8)
     8,               F172K(7),NOUT1(10),NOUT2(10),SOL(21),DEV(10,21),
     9                DEVV(10,5),DX(10),X(10),DOO(5),IFANGS(1),
     O                NOUT3(10),NBLAD(10)
      COMMON /UD3PRT/ IPRTC
      DATA    F137B / 0.0,10.0,20.0,30.0,40.0,50.0,60.0,70.0/
      DATA    F137S / 0.4,0.8,1.2,1.6,2.0/
      DATA    F142TC/ 0.0,0.02,0.04,0.06,0.08,0.10,0.12/
      DATA    F161D / 0.0,0.009,0.17,0.29,0.42,0.59,0.79,1.05,0.0,0.12,
     1                0.30,0.51,0.75,1.05,1.47,2.07,0.0,0.16,0.33,0.61,
     2                0.95,1.42,2.12,3.07,0.0,0.17,0.40,0.72,1.11,1.71,
     3                2.62,3.95,0.0,0.2,0.44,0.78,1.21,1.90,3.01,4.75/
      DATA    F195M / 0.17,0.173,0.179,0.189,0.206,0.232,0.269,0.310,
     1                0.25,0.255,0.261,0.268,0.278,0.292,0.312,0.342 /
      DATA    F164XB/ 0.965,0.945,0.921,0.890,0.850,0.782,0.679,0.550/
      DATA    F172K / 0.0,0.160,0.331,0.521,0.74,1.0,1.300/
C
      LMAX   = 60
      CALL FREAD (LOG1,IDATA,6,1)
      NRAD   = IDATA(1)
      NDPTS  = IDATA(2)
      NDATR  = IDATA(3)
      NSWITC = IDATA(4)
      NLE    = IDATA(5)
      NTE    = IDATA(6)
      CALL FREAD (LOG1,RDATA,2,1)
      XKSHPE = RDATA(1)
      SPEED  = RDATA(2)
      CALL FREAD (LOG1,IDATA,3,1)
      NOUT1(NLE) = IDATA(1)
      NOUT2(NLE) = IDATA(2)
      NOUT3(NLE) = IDATA(3)
      IF (IPRTC .EQ. 1) WRITE (LOG2,20) NRAD,NDPTS,NDATR,NSWITC,NLE,NTE,
     1       XKSHPE,SPEED,NLE,NOUT1(NLE),NOUT2(NLE),NOUT3(NLE)
   20 FORMAT (1H1,9X,'DATA INTERFACING ROUTINE - DEVIATION CALCULATIONS'
     1,      ' AND DATA FORMATTING', /10X,69(1H*), /10X,5HINPUT, /10X,
     2       5(1H*), //10X,6HNRAD =,I3,9H  NDPTS =,I3,9H  NDATR =,I3,
     3       11H  NSWITCH =,I2,7H  NLE =,I2,7H  NTE =,I3, //10X,
     4       8HXKSHPE =,F7.4,9H  SPEED =,F9.1, //10X,'AT LEADING EDGE ',
     5       '(STATION,I3,9H) NOUT1 =',I2,9H  NOUT2 =,I2,9H  NOUT3 =,I2)
      LNCT = 10
      K    = NLE + 1
      DO 80 I = K,NTE
      CALL FREAD (LOG1,IDATA,14,1)
      NR(I)     = IDATA(1)
      NTERP(I)  = IDATA(2)
      NMACH(I)  = IDATA(3)
      NLOSS(I)  = IDATA(4)
      NL1(I)    = IDATA(5)
      NL2(I)    = IDATA(6)
      NEVAL(I)  = IDATA(7)
      NCURVE(I) = IDATA(8)
      NLITER(I) = IDATA(9)
      NDEL(I)   = IDATA(10)
      NOUT1(I)  = IDATA(11)
      NOUT2(I)  = IDATA(12)
      NOUT3(I)  = IDATA(13)
      NBLAD(I)  = IDATA(14)
      IF (LNCT+6+NR(I) .LE. LMAX) GO TO 50
      IF (IPRTC .NE. 0) WRITE (LOG2,40)
   40 FORMAT (1H1)
      LNCT = 1
   50 LNCT = LNCT + 6 + NR(I)
      IF (IPRTC .EQ. 1) WRITE (LOG2,60) I,NR(I),NTERP(I),NMACH(I),
     1       NLOSS(I),NL1(I),NL2(I),NEVAL(I),NCURVE(I),NLITER(I),
     2       NDEL(I),NOUT1(I),NOUT2(I),NOUT3(I),NBLAD(I)
   60 FORMAT (/10X,7HSTATION,I3,7H   NR =,I3,9H  NTERP =,I2,9H  NMACH =,
     1       I2,9H  NLOSS =,I2,7H  NL1 =,I3,7H  NL2 =,I3,9H  NEVAL =,I2,
     2       8HNCURVE =,I2,10H  NLITER =,I3,8H  NDEL =,I2, /22X,
     3       7HNOUT1 =,I2,9H  NOUT2 =,I2,9H  NOUT3 =,I2,9H  NBLAD =,I3)
      L1 = NR(I)
      DO 70 J = 1,L1
      CALL FREAD (LOG1,RDATA,2,1)
      RR(J,I)    = RDATA(1)
   70 XLOSS(J,I) = RDATA(2)
   80 IF (IPRTC .EQ. 1) WRITE (LOG2,90) (RR(J,I),XLOSS(J,I),J=1,L1)
   90 FORMAT (/14X,6HRADIUS,6X,15HLOSS DESCRIPTOR,//,(F20.4,F17.6))
      IF (LNCT+7+NDPTS .LE. LMAX) GO TO 100
      IF (IPRTC .NE. 0) WRITE (LOG2,40)
      LNCT = 1
  100 LNCT = LNCT + 2
      IF (IPRTC .EQ. 1) WRITE (LOG2,110) NRAD
  110 FORMAT (/10X,28HDEVIATION FRACTION CURVES AT,I2,6H RADII)
      DO 140 K = 1,NRAD
      IF (LNCT+5+NDPTS .LE. LMAX) GO TO 120
      IF (IPRTC .NE. 0) WRITE (LOG2,40)
      LNCT = 1
  120 LNCT = LNCT + 5 + NDPTS
      CALL FREAD (LOG1,RTE(K),1,1)
      DO 130 J = 1,NDPTS
      CALL FREAD (LOG1,RDATA,2,1)
      DM(J,K)     = RDATA(1)
  130 DVFRAC(J,K) = RDATA(2)
  140 IF (IPRTC .EQ. 1) WRITE (LOG2,150) RTE(K),(DM(J,K),DVFRAC(J,K),
     1       J=1,NDPTS)
  150 FORMAT (/10X,5HRTE =,F8.4, //15X,2HDM,10X,6HDVFRAC, //,
     1       (F20.5,F13.5))
      DO 160 J = 1,NDATR
      CALL FREAD (LOG1,RDATA,3,1)
      RDTE(J)   = RDATA(1)
      DELTAD(J) = RDATA(2)
  160 AC(J)     = RDATA(3)
      IF (LNCT+3+NDATR .LE. LMAX) GO TO 170
      IF (IPRTC .NE. 0) WRITE (LOG2,40)
      LNCT = 1
  170 LNCT = LNCT + 3 + NDATR
      IF (IPRTC .EQ. 1) WRITE (LOG2,180) (RDTE(J),DELTAD(J),AC(J),
     1       J=1,NDATR)
  180 FORMAT (/15X,4HRDTE,6X,6HDELTAD,9X,2HAC,//,(F20.4,F11.3,F13.4))
      IF (LNCT+6+NLINES .LE. LMAX) GO TO 190
      IF (IPRTC .NE. 0) WRITE (LOG2,40)
      LNCT = 1
  190 LNCT = LNCT + 6 + NLINES
      IF (IPRTC .EQ. 1) WRITE (LOG2,200)
  200 FORMAT (/10X,7HRESULTS, /,10X,7(1H*))
      IF (IPRTC .EQ. 1) WRITE (LOG2,210)
  210 FORMAT (/5X,10HSTREAMLINE,5X,5HBETA1,6X,5HBETA2,5X,6HCAMBER,7X,
     1       3HT/C,8X,3HA/C,6X,8HSOLIDITY,4X,11HADDIT. DEVN,4X,
     2       15HTOTAL DEVIATION,/)
      DO 290 J = 1,NLINES
      XJ = J
      CALL ALG15 (ZR,B1,NSPEC,XJ,BETA1,1,0)
      CALL ALG15 (ZR,B2,NSPEC,XJ,BETA2,1,0)
      CALL ALG15 (ZR,TC,NSPEC,XJ,THICK,1,0)
      Q = 1.0
      IF (SPEED .GT. 0.0) Q = -1.0
      CAMBER = (BETA1-BETA2)*Q
      SOLID  = CCORD(J)*FLOAT(NBLADE)/(PI*(R(NLE,J)+R(NTE,J)))
      BETA1  = BETA1*Q
      CALL ALG15 (F137B,F195M(1,NSWITC),8,BETA1,XMS,1,0)
      CALL ALG15 (F137B,F164XB,8,BETA1,XB,1,0)
      CALL ALG15 (F142TC,F172K,7,THICK,XKDT,1,0)
      DO 220 K = 1,5
  220 CALL ALG15 (F137B,F161D(1,K),8,BETA1,DOO(K),1,0)
      CALL ALG15 (F137S,DOO,5,SOLID,DO,1,1)
      CALL ALG15 (RDTE,DELTAD,NDATR,R(NTE,J),DADD,1,0)
      CALL ALG15 (RDTE,AC,NDATR,R(NTE,J),AONC,1,0)
      SOL(J) = SOLID
      DEV(NTE,J) = (DADD+DO*XKSHPE*XKDT+CAMBER*SOLID**(-XB)*
     1             (XMS+0.5*(AONC-0.5)))*Q
      BETA2  = BETA2*Q
      DO 230 I = NLE,NTE
  230 CALL ALG15 (RSTA(1,I),XSTA(1,I),KPTS(I),R(I,J),X(I),1,0)
      DX(NLE) = 0.0
      K = NLE + 1
      DO 240 I = K,NTE
  240 DX(I) = DX(I-1) + SQRT((X(I)-X(I-1))**2+(R(I,J)-R(I-1,J))**2)
      X1 = DX(NTE)
      DO 250 I = K,NTE
  250 DX(I) = DX(I)/X1
      L2 = NTE - NLE - 1
      K  = NLE + 1
      DO 260 L1 = 1,NRAD
  260 CALL ALG15 (DM(1,L1),DVFRAC(1,L1),NDPTS,DX(K),DEVV(K,L1),L2,0)
      KK = NTE - 1
      DO 280 I  = K,KK
      DO 270 L1 = 1,NRAD
  270 DOO(L1) = DEVV(I,L1)
      CALL ALG15 (RTE,DOO,NRAD,R(NTE,J),DEVFR,1,0)
  280 DEV(I,J) = DEV(NTE,J)*DEVFR
  290 IF (IPRTC .EQ. 1) WRITE (LOG2,300) J,BETA1,BETA2,CAMBER,THICK,
     1       AONC,SOLID,DADD,DEV(NTE,J)
  300 FORMAT (I11,F14.3,2F11.3,2F11.4,F12.5,F14.4,F17.4)
      IF (IFANGS(NLE) .EQ. 0) GO TO 340
      IF (NAERO .EQ. 0) GO TO 330
      IDATA(1)  = NLINES
      IDATA(2)  = 0
      IDATA(3)  = 0
      IDATA(4)  = 0
      IDATA(5)  = 0
      IDATA(6)  = 0
      IDATA(7)  = 0
      IDATA(8)  = 0
      IDATA(9)  = 0
      IDATA(10) = 0
      IDATA(11) = 0
      IDATA(12) = 0
      IDATA(13) = NOUT1(NLE)
      IDATA(14) = NOUT2(NLE)
      IDATA(15) = NOUT3(NLE)
      IDATA(16) = 0
      CALL WRITE (LOG5,IDATA,16,1)
      CALL WRITE (LOG5,0.0,1,1)
  310 FORMAT (I3,11(2X,1H0),3I3,3H  0, /,4H 0.0)
      DO 315 J = 1,NLINES
      RDATA(1) = R(NLE,J)
      RDATA(2) = ALPB(NLE,J)
      RDATA(3) = 0.0
      RDATA(4) = EPSLON(NLE,J)
      RDATA(5) = 0.0
      RDATA(6) = 0.0
      CALL WRITE (LOG5,RDATA,6,1)
      RDATA(1) = 0.0
      RDATA(2) = 0.0
      RDATA(3) = 0.0
      RDATA(4) = 0.0
  315 CALL WRITE (LOG5,RDATA,4,1)
  320 FORMAT (2F12.7,12X,F12.7,24X,/,4H 0.0,44X)
      IF (IPUNCH .EQ. 0) GO TO 340
  330 WRITE (LOG3,310) NLINES,NOUT1(NLE),NOUT2(NLE),NOUT3(NLE)
      WRITE (LOG3,320) (R(NLE,J),ALPB(NLE,J),EPSLON(NLE,J),J=1,NLINES)
  340 DO 370 I = K,NTE
      DO 350 J = 1,NLINES
  350 RDTE(J) = R(I,J)
      CALL ALG15 (RR(1,I),XLOSS(1,I),NR(I),RDTE,DELTAD,NLINES,0)
      NX = LOG5
      IF (NAERO .EQ. 0) NX = LOG3
      IF (NX .EQ. LOG3) GO TO 360
      IDATA(1)  = NLINES
      IDATA(2)  = NTERP(I)
      IDATA(3)  = 0
      IDATA(4)  = NMACH(I)
      IDATA(5)  = 6
      IDATA(6)  = NLOSS(I)
      IDATA(7)  = NL1(I)
      IDATA(8)  = NL2(I)
      IDATA(9)  = NEVAL(I)
      IDATA(10) = NCURVE(I)
      IDATA(11) = NLITER(I)
      IDATA(12) = NDEL(I)
      IDATA(13) = NOUT1(I)
      IDATA(14) = NOUT2(I)
      IDATA(15) = NOUT3(I)
      IDATA(16) = NBLAD(I)
      CALL WRITE (LOG5,IDATA,16,1)
      CALL WRITE (LOG5,SPEED,1,1)
      DO 355 J = 1,NLINES
      RDATA(1) = R(I,J)
      RDATA(2) = ALPB(I,J)
      RDATA(3) = DELTAD(J)
      RDATA(4) = EPSLON(I,J)
      RDATA(5) = BLOCK(I,J)
      RDATA(6) = SOL(J)
      CALL WRITE (LOG5,RDATA,6,1)
      RDATA(1) = DEV(I,J)
      RDATA(2) = 0.0
      RDATA(3) = 0.0
      RDATA(4) = 0.0
  355 CALL WRITE (LOG5,RDATA,4,1)
      GO TO 365
  360 WRITE (NX,380) NLINES,NTERP(I),NMACH(I),NLOSS(I),NL1(I),NL2(I),
     1       NEVAL(I),NCURVE(I),NLITER(I),NDEL(I),NOUT1(I),NOUT2(I),
     2       NOUT3(I),NBLAD(I),SPEED,(R(I,J),ALPB(I,J),DELTAD(J),
     3       EPSLON(I,J),BLOCK(I,J),SOL(J),DEV(I,J),J=1,NLINES)
  365 IF (NX .EQ. LOG3) GO TO 370
      NX = LOG3
      IF (NAERO.NE.0 .AND. IPUNCH.NE.0) GO TO 360
  370 CONTINUE
  380 FORMAT (2I3,3H  0,I3,3H  6,11I3, /,F12.3,/,(6F12.7, /,F12.7,36X))
      RETURN
      END


SUBROUTINE dbgdmp(day,sr)
!
IMPLICIT NONE
!
INCLUDE 'p1werm.inc'
INCLUDE 'm1subr.inc'
INCLUDE 'm1sim.inc'
INCLUDE 's1layr.inc'
INCLUDE 's1surf.inc'
INCLUDE 's1phys.inc'
INCLUDE 's1agg.inc'
INCLUDE 's1dbh.inc'
INCLUDE 's1dbc.inc'
INCLUDE 's1sgeo.inc'
INCLUDE 'c1gen.inc'
INCLUDE 'c1db1.inc'
INCLUDE 'c1db2.inc'
INCLUDE 'c1db3.inc'
INCLUDE 'c1glob.inc'
INCLUDE 'd1glob.inc'
INCLUDE 'b1glob.inc'
INCLUDE 'w1clig.inc'
INCLUDE 'w1wind.inc'
INCLUDE 'w1pavg.inc'
INCLUDE 'h1hydro.inc'
INCLUDE 'h1scs.inc'
INCLUDE 'h1db1.inc'
INCLUDE 'h1temp.inc'
!
! PARAMETER definitions
!
REAL,PARAMETER :: tstmin = 1E-10,tstmax = 1E10
!
! Subroutine arguments
!
INTEGER :: day,sr
!
! Local variables
!
LOGICAL :: dmpflg
INTEGER :: idx,jdx
!
! ****************************************************************** wjr
!     the dumps variables that have gone out of range

!       edit history
!       01-mar-99       wjr     original coding

!     + + + global common blocks + + +

!     include 'p1unconv.inc'
!     include 'wpath.inc'
!     include 'm1geo.inc'
!     include 'm1flag.inc'
!     include 'm1dbug.inc'
!     include 'c1info.inc'

!     + + + local common blocks + + +
!     include 'main.inc'
!     include 'man.inc'
!     include 'm2geo.inc'
!     include 'e2erod.inc'

!
!
!
DATA dmpflg/.TRUE./
! prototype, remove before compiling
!      if (#(sr).lt.tstmin.or.#(sr).gt.tstmax)
!     &  write(*,*) 'day ',day,' # ', #(sr)

! s1surf

IF (dmpflg) WRITE (*,*) 's1surf'
!
IF (aszcr(sr).LT.0.0.OR.aszcr(sr).GT.23.0) WRITE (*,*) 'day ',day,' aszcr ',    &
  & aszcr(sr)
!
IF (asfcr(sr).LT.0.0.OR.asfcr(sr).GT.1.0) WRITE (*,*) 'day ',day,' asfcr ',     &
  & asfcr(sr)
!
IF (asmlos(sr).LT.0.0.OR.asmlos(sr).GT.2.0) WRITE (*,*) 'day ',day,' asmlos ',  &
  & asmlos(sr)
!
IF (asflos(sr).LT.0.0.OR.asflos(sr).GT.1.0) WRITE (*,*) 'day ',day,' asflos ',  &
  & asflos(sr)
!
! wjr,  test values based on definition
IF (asdcr(sr).LT.0.6.OR.asdcr(sr).GT.2.0) WRITE (*,*) 'day ',day,' asdcr ',     &
  & asdcr(sr)
!
IF (asecr(sr).LT.0.1.OR.asecr(sr).GT.7.0) WRITE (*,*) 'day ',day,' asecr ',     &
  & asecr(sr)
!
IF (asfald(sr).LT.0.05.OR.asfald(sr).GT.0.25) WRITE (*,*) 'day ',day,' asfald ',&
  & asfald(sr)
!
IF (asfalw(sr).LT.0.05.OR.asfalw(sr).GT.0.2) WRITE (*,*) 'day ',day,' asfalw ', &
  & asfalw(sr)
!
! w1info
!
! ***      if (aw0cln.lt.70.0.or.aw0cln.gt.170.0)
! ***     *  write(*,*) 'day ',day,' aw0cln ', aw0cln
!
! ***      if (aw0clt.lt.15.0.or.aw0clt.gt.75.0)
! ***     *  write(*,*) 'day ',day,' aw0clt ', aw0clt
!
! ***      if (aw0wln.lt.70.0.or.aw0wln.gt.170.0)
! ***     *  write(*,*) 'day ',day,' aw0wln ', aw0wln
!
! ***      if (aw0wlt.lt.15.0.or.aw0wlt.gt.75.0)
! ***     *  write(*,*) 'day ',day,' aw0wlt ', aw0wlt
!
! s1sgeo
!
IF (dmpflg) WRITE (*,*) 's1sgeo'
!
IF (aszrgh(sr).LT.0.0.OR.aszrgh(sr).GT.500.0) WRITE (*,*) 'day ',day,' aszrgh ',&
  & aszrgh(sr)
!
IF (asxrgw(sr).LT.10.0.OR.asxrgw(sr).GT.4000.0) WRITE (*,*) 'day ',day,         &
   &' asxrgw ',asxrgw(sr)
!
IF (asxrgs(sr).LT.10.0.OR.asxrgs(sr).GT.2000.0) WRITE (*,*) 'day ',day,         &
   &' asxrgs ',asxrgs(sr)
!
IF (asargo(sr).LT.0.0.OR.asargo(sr).GT.179.0) WRITE (*,*) 'day ',day,' asargo ',&
  & asargo(sr)
!
! wjr,  test values based on definition
IF (asxdks(sr).LT.0.0.OR.asxdks(sr).GT.1000.0) WRITE (*,*) 'day ',day,          &
  & ' asxdks ',asxdks(sr)
!
! wjr,  test values based on definition
IF (asxdkh(sr).LT.0.0.OR.asxdkh(sr).GT.1000.0) WRITE (*,*) 'day ',day,          &
  & ' asxdkh ',asxdkh(sr)
!
IF (as0rrk(sr).LT.tstmin.OR.as0rrk(sr).GT.tstmax) WRITE (*,*) 'day ',day,       &
   &' as0rrk ',as0rrk(sr)
!
IF (aslrrc(sr).LT.tstmin.OR.aslrrc(sr).GT.tstmax) WRITE (*,*) 'day ',day,       &
   &' aslrrc ',aslrrc(sr)
!
IF (aslrr(sr).LT.1.0.OR.aslrr(sr).GT.30.0) WRITE (*,*) 'day ',day,' aslrr ',    &
  & aslrr(sr)
!
! w1wind
!
IF (dmpflg) WRITE (*,*) 'w1wind'
!
! wjr,  test values based on definition
IF (awadir.LT.0.0.OR.awadir.GT.360.0) WRITE (*,*) 'day ',day,' awadir ',awadir
!
IF (awhrmx.LT.1.0.OR.awhrmx.GT.24.0) WRITE (*,*) 'day ',day,' awhrmx ',awhrmx
!
IF (awrmxn.LT.0.0.OR.awrmxn.GT.tstmax) WRITE (*,*) 'day ',day,' awrmxn ',awrmxn
!
! wjr,  test values based on definition
IF (awudmx.LT.0.0.OR.awudmx.GT.50.0) WRITE (*,*) 'day ',day,' awudmx ',awudmx
!
! wjr,  test values based on definition
IF (awudmn.LT.0.0.OR.awudmn.GT.25.0) WRITE (*,*) 'day ',day,' awudmn ',awudmn
!
! wjr,  test values based on definition
IF (awudav.LT.0.0.OR.awudav.GT.35.0) WRITE (*,*) 'day ',day,' awudav ',awudav
!
DO idx = 1,mntime
! wjr,  test values based on definition
  IF (awu(idx).LT.0.0.OR.awu(idx).GT.35.0) WRITE (*,*) 'day ',day,' awu(',idx,  &
     &') ',awu(idx)
END DO
!
! w1pagv
!
! wjr,  test values based on definition
IF (awtmmx.LT.-10.0.OR.awtmmx.GT.40.0) WRITE (*,*) 'day ',day,' awtmmx ',awtmmx
!
! wjr,  test values based on definition
IF (awtmmn.LT.-20.0.OR.awtmmn.GT.30.0) WRITE (*,*) 'day ',day,' awtmmn ',awtmmn
!
! wjr,  test values based on definition
IF (awdair.LT.0.0.OR.awdair.GT.tstmax) WRITE (*,*) 'day ',day,' awdair ',awdair
!
! wjr,  test values based on definition
IF (awztpt.LT.0.0.OR.awztpt.GT.500.0) WRITE (*,*) 'day ',day,' awztpt ',awztpt
!
! wjr,  test values based on definition
IF (awtpav.LT.-20.0.OR.awtpav.GT.40) WRITE (*,*) 'day ',day,' awtpav ',awtpav
!
! ***      if (awepir.lt.tstmin.or.awepir.gt.tstmax)
! ***     *  write(*,*) 'day ',day,' awepir ', awepir
!
! wjr,  test values based on definition
IF (awupav.LT.0.0.OR.awupav.GT.30.0) WRITE (*,*) 'day ',day,' awupav ',awupav
!
! wjr,  test values based on definition
IF (awnuet.LT.0.OR.awnuet.GT.31.0) WRITE (*,*) 'day ',day,' awnuet ',awnuet
!
! wjr,  test values based on definition
IF (aweuet.LT.0.0.OR.aweuet.GT.tstmax) WRITE (*,*) 'day ',day,' aweuet ',aweuet
!
! b1geom
!
IF (dmpflg) WRITE (*,*) 'b1geom'
!
! wjr,  test values based on definition
IF (abrsai(sr).LT.0.0.OR.abrsai(sr).GT.1.0) WRITE (*,*) 'day ',day,' abrsai ',  &
  & abrsai(sr)
!
! wjr,  test values based on definition
IF (abrlai(sr).LT.0.0.OR.abrlai(sr).GT.1.0) WRITE (*,*) 'day ',day,' abrlai ',  &
  & abrlai(sr)
!
DO idx = 1,mncz
!
! wjr,  test values based on definition
  IF (abrsaz(idx,sr).LT.0.0.OR.abrsaz(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,&
     &' abrsaz(',idx,') ',abrsaz(idx,sr)
!
! wjr,  test values based on definition
  IF (abrlaz(idx,sr).LT.0.0.OR.abrlaz(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,&
     &' abrlaz(',idx,') ',abrlaz(idx,sr)
!
END DO
!
! wjr,  test values based on definition
IF (abffcv(sr).LT.0.0.OR.abffcv(sr).GT.1.0) WRITE (*,*) 'day ',day,' abffcv ',  &
  & abffcv(sr)
!
! wjr,  test values based on definition
IF (abfscv(sr).LT.0.0.OR.abfscv(sr).GT.1.0) WRITE (*,*) 'day ',day,' abfscv ',  &
  & abfscv(sr)
!
! wjr,  test values based on definition
IF (abftcv(sr).LT.0.0.OR.abftcv(sr).GT.1.0) WRITE (*,*) 'day ',day,' abftcv ',  &
  & abftcv(sr)
!
! w1clig
!
IF (dmpflg) WRITE (*,*) 'w1clig'
!
! wjr,  test values based on definition
IF (awrrh.LT.0.0.OR.awrrh.GT.100.0) WRITE (*,*) 'day ',day,' awrrh ',awrrh
!
! wjr,  test values based on definition
IF (awtdav.LT.-20.0.OR.awtdav.GT.50.0) WRITE (*,*) 'day ',day,' awtdav ',awtdav
!
! wjr,  test values based on definition
IF (awtyav.LT.0.0.OR.awtyav.GT.30.0) WRITE (*,*) 'day ',day,' awtyav ',awtyav
!
DO idx = 1,12
! wjr,  test values based on definition
  IF (awtmav(idx).LT.-10.0.OR.awtmav(idx).GT.40.0) WRITE (*,*) 'day ',day,      &
     &' awtmav(',idx,') ',awtmav(idx)
END DO
!
! wjr,  test values based on definition
IF (awtdmx.LT.0.0.OR.awtdmx.GT.50.0) WRITE (*,*) 'day ',day,' awtdmx ',awtdmx
!
! wjr,  test values based on definition
IF (awtdmn.LT.-20.0.OR.awtdmn.GT.40.0) WRITE (*,*) 'day ',day,' awtdmn ',awtdmn
!
! wjr,  test values based on definition
IF (awtdpt.LT.0.0.OR.awtdpt.GT.40.0) WRITE (*,*) 'day ',day,' awtdpt ',awtdpt
!
! wjr,  test values based on definition
IF (awzdpt.LT.0.0.OR.awzdpt.GT.1000.0) WRITE (*,*) 'day ',day,' awzdpt ',awzdpt
!
! wjr,  test values based on definition
IF (aweirr.LT.0.0.OR.aweirr.GT.tstmax) WRITE (*,*) 'day ',day,' aweirr ',aweirr
!
! s1psd
!
! ***      do 40 idx=1,mnsz
! ***      if (aslsgm(idx, sr).lt.0.0.or.aslsgm(idx, sr).gt.10.0)
! ***     *  write(*,*) 'day ',day,' aslsgm ', aslsgm(idx, sr)
!
! ***      if (as0sgs(idx, sr).lt.0.0.or.as0sgs(idx, sr).gt.10.0)
! ***     *  write(*,*) 'day ',day,' as0sgs ', as0sgs(idx, sr)
! ***   40 continue
!
! s1layd
!
IF (dmpflg) WRITE (*,*) 's1layd'
!
DO idx = 1,nslay(sr)
  IF (asdsblk(idx,sr).LT.tstmin.OR.asdsblk(idx,sr).GT.tstmax) WRITE (*,*)       &
    & 'day ',day,' asdsblk(',idx,') ',asdsblk(idx,sr)
!
  IF (aszlyd(idx,sr).LT.tstmin.OR.aszlyd(idx,sr).GT.tstmax) WRITE (*,*) 'day ', &
    & day,' aszlyd(',idx,') ',aszlyd(idx,sr)
!
! ***      if (aszlym(idx, sr).lt.tstmin.or.aszlym(idx, sr).gt.tstmax)
! ***     *  write(*,*) 'day ',day,' aszlym(',idx,') ', aszlym(idx, sr)
!
! ***      if (aszmpt(idx, sr).lt.tstmin.or.aszmpt(idx, sr).gt.tstmax)
! ***     *  write(*,*) 'day ',day,' aszmpt(',idx,') ', aszmpt(idx, sr)
END DO
!
! s1layr
!
IF (dmpflg) WRITE (*,*) 's1layr'
!
IF (nslay(sr).LT.1.OR.nslay(sr).GT.10) WRITE (*,*) 'day ',day,' nslay ',        &
  & nslay(sr)
!
IF (aszlyt(1,sr).LT.10.0.OR.aszlyt(1,sr).GT.10.0) WRITE (*,*) 'day ',day,       &
   &' aszlyt(1) ',aszlyt(1,sr)
!
IF (nslay(sr).GT.1.AND.(aszlyt(2,sr).LT.40.0.OR.aszlyt(2,sr).GT.40.0))          &
  & WRITE (*,*) 'day ',day,' aszlyt(2) ',aszlyt(2,sr)
!
IF (nslay(sr).GT.2.AND.(aszlyt(3,sr).LT.50.0.OR.aszlyt(3,sr).GT.100.0))         &
  & WRITE (*,*) 'day ',day,' aszlyt(3) ',aszlyt(3,sr)
!
IF (nslay(sr).GT.3.AND.(aszlyt(4,sr).LT.50.0.OR.aszlyt(4,sr).GT.100.0))         &
  & WRITE (*,*) 'day ',day,' aszlyt(4) ',aszlyt(4,sr)
!
DO idx = 5,mnsz + 1
  IF (nslay(sr).GE.idx.AND.(aszlyt(idx,sr).LT.1.0.OR.aszlyt(idx,sr).GT.1000.0)) &
    & WRITE (*,*) 'day ',day,' aszlyt(',idx,') ',aszlyt(idx,sr)
END DO
!
! s1phys
!
IF (dmpflg) WRITE (*,*) 's1phys'
!
DO idx = 0,mnsz
  IF (asdblk(idx,sr).LT.0.50.OR.asdblk(idx,sr).GT.2.5) WRITE (*,*) 'day ',day,  &
     &' asdblk(',idx,') ',asdblk(idx,sr)
END DO
!
! s1dbh
!
IF (dmpflg) WRITE (*,*) 's1dbh'
!
DO idx = 0,mnsz
  IF (asfsan(idx,sr).LT.0.0.OR.asfsan(idx,sr).GT.1.0) WRITE (*,*) 'day ',day,   &
     &' asfsan(',idx,') ',asfsan(idx,sr)
!
  IF (asfsil(idx,sr).LT.0.0.OR.asfsil(idx,sr).GT.1.0) WRITE (*,*) 'day ',day,   &
     &' asfsil(',idx,') ',asfsil(idx,sr)
!
  IF (asfcla(idx,sr).LT.0.0.OR.asfcla(idx,sr).GT.1.0) WRITE (*,*) 'day ',day,   &
     &' asfcla(',idx,') ',asfcla(idx,sr)
!
  IF (asvroc(idx,sr).LT.0.0.OR.asvroc(idx,sr).GT.1.0) WRITE (*,*) 'day ',day,   &
     &' asvroc(',idx,') ',asvroc(idx,sr)
END DO
!
! s1agg
!
IF (dmpflg) WRITE (*,*) 's1agg'
!
DO idx = 0,mnsz
  IF (asdagd(idx,sr).LT.0.6.OR.asdagd(idx,sr).GT.2.5) WRITE (*,*) 'day ',day,   &
     &' asdagd(',idx,') ',asdagd(idx,sr)
!
  IF (aseags(idx,sr).LT.0.1.OR.aseags(idx,sr).GT.7.0) WRITE (*,*) 'day ',day,   &
     &' aseags(',idx,') ',aseags(idx,sr)
!
  IF (aslagm(idx,sr).LT.0.03.OR.aslagm(idx,sr).GT.30.0) WRITE (*,*) 'day ',day, &
     &' aslagm(',idx,') ',aslagm(idx,sr)
!
  IF (aslagn(idx,sr).LT.0.001.OR.aslagn(idx,sr).GT.5.0) WRITE (*,*) 'day ',day, &
     &' aslagn(',idx,') ',aslagn(idx,sr)
!
  IF (aslagx(idx,sr).LT.1.0.OR.aslagx(idx,sr).GT.1000.0) WRITE (*,*) 'day ',day,&
     &' aslagx(',idx,') ',aslagx(idx,sr)
!
  IF (as0ags(idx,sr).LT.1.0.OR.as0ags(idx,sr).GT.20.0) WRITE (*,*) 'day ',day,  &
     &' as0ags(',idx,') ',as0ags(idx,sr)
END DO
!
! s1dbc
!
IF (dmpflg) WRITE (*,*) 's1dbc'
!
IF (asfom(0,sr).LT.tstmin.OR.asfom(0,sr).GT.tstmax) WRITE (*,*) 'day ',day,     &
   &' asfom(0) ',asfom(0,sr)
!
DO idx = 1,mnsz
  IF (as0ph(idx,sr).LT.0.0.OR.as0ph(idx,sr).GT.14.0) WRITE (*,*) 'day ',day,    &
     &' as0ph(',idx,') ',as0ph(idx,sr)
!
  IF (ascmg(idx,sr).LT.0.0.OR.ascmg(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,  &
     &' ascmg(',idx,') ',ascmg(idx,sr)
!
  IF (ascna(idx,sr).LT.0.0.OR.ascna(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,  &
     &' ascna(',idx,') ',ascna(idx,sr)
!
  IF (asfcce(idx,sr).LT.0.0.OR.asfcce(idx,sr).GT.100.0) WRITE (*,*) 'day ',day, &
     &' asfcce(',idx,') ',asfcce(idx,sr)
!
  IF (asfcec(idx,sr).LT.0.0.OR.asfcec(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,&
     &' asfcec(',idx,') ',asfcec(idx,sr)
!
  IF (asfesp(idx,sr).LT.0.0.OR.asfesp(idx,sr).GT.100.0) WRITE (*,*) 'day ',day, &
     &' asfesp(',idx,') ',asfesp(idx,sr)
!
  IF (asfom(idx,sr).LT.0.0.OR.asfom(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,  &
     &' asfom(',idx,') ',asfom(idx,sr)
!
  IF (asfnoh(idx,sr).LT.0.0.OR.asfnoh(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,&
     &' asfnoh(',idx,') ',asfnoh(idx,sr)
!
  IF (asfpoh(idx,sr).LT.0.0.OR.asfpoh(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,&
     &' asfpoh(',idx,') ',asfpoh(idx,sr)
!
  IF (asfpsp(idx,sr).LT.0.0.OR.asfpsp(idx,sr).GT.1.0) WRITE (*,*) 'day ',day,   &
     &' asfpsp(',idx,') ',asfpsp(idx,sr)
!
  IF (asfsmb(idx,sr).LT.0.0.OR.asfsmb(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,&
     &' asfsmb(',idx,') ',asfsmb(idx,sr)
!
  IF (asftap(idx,sr).LT.0.0.OR.asftap(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,&
     &' asftap(',idx,') ',asftap(idx,sr)
!
  IF (asftan(idx,sr).LT.0.0.OR.asftan(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,&
     &' asftan(',idx,') ',asftan(idx,sr)
END DO
!
IF (asmno3(sr).LT.0.0.OR.asmno3(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' asmno3 ',asmno3(sr)
!
! m1sim
!
IF (dmpflg) WRITE (*,*) 'm1sim'
!
IF (ntstep.LT.1.OR.ntstep.GT.96) WRITE (*,*) 'day ',day,' ntstep ',ntstep
!
IF (am0jd.NE.day) WRITE (*,*) 'day ',day,' am0jd ',am0jd
!
IF (amalat.LT.15.0.OR.amalat.GT.75.0) WRITE (*,*) 'day ',day,' amalat ',amalat
!
IF (amalon.LT.70.0.OR.amalon.GT.170.0) WRITE (*,*) 'day ',day,' amalon ',amalon
!
IF (amzele.LT.0.0.OR.amzele.GT.2500.0) WRITE (*,*) 'day ',day,' amzele ',amzele
!
! m1subr
!
IF (dmpflg) WRITE (*,*) 'm1subr'
!
IF (nsubr.LT.1.OR.nsubr.GT.4) WRITE (*,*) 'day ',day,' nsubr ',nsubr
!
IF (am0csr.LT.1.OR.am0csr.GT.4) WRITE (*,*) 'day ',day,' am0csr ',am0csr
!
IF (amnryr(sr).LT.1.OR.amnryr(sr).GT.10) WRITE (*,*) 'day ',day,' amnryr ',     &
  & amnryr(sr)
!
IF (amrslp(sr).LT.0.0.OR.amrslp(sr).GT.1.0) WRITE (*,*) 'day ',day,' amrslp ',  &
  & amrslp(sr)
!
! h1temp
!
IF (dmpflg) WRITE (*,*) 'h1temp'
!
DO idx = 1,mnsz
  IF (ahtsav(idx,sr).LT.-20.0.OR.ahtsav(idx,sr).GT.50.0) WRITE (*,*) 'day ',day,&
     &' ahtsav(',idx,') ',ahtsav(idx,sr)
!
  IF (ahtsmx(idx,sr).LT.-20.0.OR.ahtsmx(idx,sr).GT.50.0) WRITE (*,*) 'day ',day,&
     &' ahtsmx(',idx,') ',ahtsmx(idx,sr)
!
  IF (ahtsmn(idx,sr).LT.-20.0.OR.ahtsmn(idx,sr).GT.50.0) WRITE (*,*) 'day ',day,&
     &' ahtsmn(',idx,') ',ahtsmn(idx,sr)
END DO
!
! h1et
!
! ***      if (ahzea.lt.0.0.or.ahzea.gt.50.0)
! ***     *  write(*,*) 'day ',day,' ahzea ', ahzea
!
! ***      if (ahzep.lt.0.0.or.ahzep.gt.50.0)
! ***     *  write(*,*) 'day ',day,' ahzep ', ahzep
!
! ***      if (ahzeta.lt.0.0.or.ahzeta.gt.50.0)
! ***     *  write(*,*) 'day ',day,' ahzeta ', ahzeta
!
! ***      if (ahzetp.lt.0.0.or.ahzetp.gt.50.0)
! ***     *  write(*,*) 'day ',day,' ahzetp ', ahzetp
!
! ***      if (ahzpta.lt.0.0.or.ahzpta.gt.50.0)
! ***     *  write(*,*) 'day ',day,' ahzpta ', ahzpta
!
! ***      if (ahzptp.lt.0.0.or.ahzptp.gt.50.0)
! ***     *  write(*,*) 'day ',day,' ahzptp ', ahzptp
!
! ***      if (ah0drat.lt.0.0.or.ah0drat.gt.1.0)
! ***     *  write(*,*) 'day ',day,' ah0drat ', ah0drat
!
! h1hydro
!
IF (dmpflg) WRITE (*,*) 'h1hydro'
!
DO idx = 1,mnsz
  IF (ahrwc(idx,sr).LT.0.011.OR.ahrwc(idx,sr).GT.0.379) WRITE (*,*) 'day ',day, &
     &' ahrwc(',idx,') ',ahrwc(idx,sr)
!
  IF (aheaep(idx,sr).LT.-17.91.OR.aheaep(idx,sr).GT.0.0) WRITE (*,*) 'day ',day,&
     &' aheaep(',idx,') ',aheaep(idx,sr)
!
  IF (ahrsk(idx,sr).LT.0.0.OR.ahrsk(idx,sr).GT.0.001) WRITE (*,*) 'day ',day,   &
     &' ahrsk(',idx,') ',ahrsk(idx,sr)
!
  IF (ah0cb(idx,sr).LT.0.917.OR.ah0cb(idx,sr).GT.27.927) WRITE (*,*) 'day ',day,&
     &' ah0cb(',idx,') ',ah0cb(idx,sr)
END DO
!
IF (ahfwsf(sr).LT.tstmin.OR.ahfwsf(sr).GT.tstmax) WRITE (*,*) 'day ',day,       &
   &' ahfwsf ',ahfwsf(sr)
!
IF (ahzsno(sr).LT.0.0.OR.ahzsno(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ahzsno ',ahzsno(sr)
!
IF (ahzirr(sr).LT.0.0.OR.ahzirr(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ahzirr ',ahzirr(sr)
!
IF (ahzper(sr).LT.0.0.OR.ahzper(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ahzper ',ahzper(sr)
!
IF (ahzrun(sr).LT.0.0.OR.ahzrun(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ahzrun ',ahzrun(sr)
!
IF (ahzsmt(sr).LT.0.0.OR.ahzsmt(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ahzsmt ',ahzsmt(sr)
!
! h1scs
!
IF (dmpflg) WRITE (*,*) 'h1scs'
!
IF (ah0cng(sr).LT.6.0.OR.ah0cng(sr).GT.91.0) WRITE (*,*) 'day ',day,' ah0cng ', &
  & ah0cng(sr)
!
IF (ah0cnp(sr).LT.45.0.OR.ah0cnp(sr).GT.94.0) WRITE (*,*) 'day ',day,' ah0cnp ',&
  & ah0cnp(sr)
!
! h1db1
!
IF (dmpflg) WRITE (*,*) 'h1db1'
!
DO idx = 1,mnsz
  IF (ahrwcw(idx,sr).LT.0.005.OR.ahrwcw(idx,sr).GT.0.242) WRITE (*,*) 'day ',   &
    & day,' ahrwcw(',idx,') ',ahrwcw(idx,sr)
!
  IF (ahrwcf(idx,sr).LT.0.012.OR.ahrwcf(idx,sr).GT.0.335) WRITE (*,*) 'day ',   &
    & day,' ahrwcf(',idx,') ',ahrwcf(idx,sr)
!
  IF (ahrwcs(idx,sr).LT.0.208.OR.ahrwcs(idx,sr).GT.0.440) WRITE (*,*) 'day ',   &
    & day,' ahrwcs(',idx,') ',ahrwcs(idx,sr)
!
  IF (ahrwca(idx,sr).LT.0.0.OR.ahrwca(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,&
     &' ahrwca(',idx,') ',ahrwca(idx,sr)
END DO
!
DO idx = 1,mnhhrs
  IF (ahrwc0(idx,sr).LT.0.0.OR.ahrwc0(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,&
     &' ahrwc0(',idx,') ',ahrwc0(idx,sr)
END DO
!
IF (ahzsnd(sr).LT.0.0.OR.ahzsnd(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ahzsnd ',ahzsnd(sr)
!
! p1werm
!
DO idx = 1,mnbpls
  IF (admf(idx,sr).LT.0.0.OR.admf(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,    &
     &' admf(',idx,')',admf(idx,sr)
END DO
!
! not used anymore
!      do 150 idx=0,mncz
!      if (adma(idx, sr).lt.0.0.or.adma(idx, sr).gt.tstmax)
!     &  write(*,*) 'day ',day,' adma(',idx,') ', adma(idx, sr)
!  150 continue
!
!      if (admbt(sr).lt.0.0.or.admbt(sr).gt.tstmax)
!     &  write(*,*) 'day ',day,' admbt ', admbt(sr)
!
DO idx = 1,mnsz
  DO jdx = 1,mnbpls
     IF (admbgz(idx,jdx,sr).LT.0.0.OR.admbgz(idx,jdx,sr).GT.tstmax) WRITE (*,*) &
        & 'day ',day,' admbgz(',idx,jdx,') ',admbgz(idx,jdx,sr)
!
     IF (admrtz(idx,jdx,sr).LT.0.0.OR.admrtz(idx,jdx,sr).GT.tstmax) WRITE (*,*) &
        & 'day ',day,' admrtz(',idx,jdx,') ',admrtz(idx,jdx,sr)
  END DO
END DO
!
! d1glob
!
IF (dmpflg) WRITE (*,*) 'd1glob'
!
DO idx = 1,mnbpls
  IF (adzht(idx,sr).LT.tstmin.OR.adzht(idx,sr).GT.tstmax) WRITE (*,*) 'day ',   &
    & day,' adzht(',idx,') ',adzht(idx,sr)

  IF (adm(idx,sr).LT.0.0.OR.adm(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,      &
     &' adm(',idx,') ',adm(idx,sr)

  IF (admst(idx,sr).LT.0.0.OR.admst(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,  &
     &' admst(',idx,') ',admst(idx,sr)

  IF (admf(idx,sr).LT.0.0.OR.admf(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,    &
     &' admf(',idx,') ',admf(idx,sr)

  IF (admbg(idx,sr).LT.0.0.OR.admbg(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,  &
     &' admbg(',idx,') ',admbg(idx,sr)

  IF (admrt(idx,sr).LT.0.0.OR.admrt(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,  &
     &' admrt(',idx,') ',admrt(idx,sr)

  IF (addstm(idx,sr).LT.0.0.OR.addstm(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,&
     &' addstm(',idx,') ',addstm(idx,sr)
END DO

! c1db3
!
IF (dmpflg) WRITE (*,*) 'c1db3'
!
IF (ac0bn1(sr).LT.0.0.OR.ac0bn1(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ac0bn1 ',ac0bn1(sr)
!
IF (ac0bn2(sr).LT.0.0.OR.ac0bn2(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ac0bn2 ',ac0bn2(sr)
!
IF (ac0bn3(sr).LT.0.0.OR.ac0bn3(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ac0bn3 ',ac0bn3(sr)
!
IF (ac0bp1(sr).LT.0.0.OR.ac0bp1(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ac0bp1 ',ac0bp1(sr)
!
IF (ac0bp2(sr).LT.0.0.OR.ac0bp2(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ac0bp2 ',ac0bp2(sr)
!
IF (ac0bp3(sr).LT.0.0.OR.ac0bp3(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ac0bp3 ',ac0bp3(sr)
!
IF (acfny(sr).LT.0.0.OR.acfny(sr).GT.1.0) WRITE (*,*) 'day ',day,' acfny ',     &
  & acfny(sr)
!
IF (acfpy(sr).LT.0.0.OR.acfpy(sr).GT.1.0) WRITE (*,*) 'day ',day,' acfpy ',     &
  & acfpy(sr)
!
IF (acfwy(sr).LT.0.0.OR.acfwy(sr).GT.1.0) WRITE (*,*) 'day ',day,' acfwy ',     &
  & acfwy(sr)
!
! c1gen
!
IF (dmpflg) WRITE (*,*) 'c1gen'
!
IF (ac0rg(sr).LT.0.OR.ac0rg(sr).GT.1) WRITE (*,*) 'day ',day,' ac0rg ',ac0rg(sr)
!
IF (acdpop(sr).LT.0.0.OR.acdpop(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' acdpop ',acdpop(sr)
!
IF (acxrow(sr).LT.0.0.OR.acxrow(sr).GT.1.0) WRITE (*,*) 'day ',day,' acxrow ',  &
  & acxrow(sr)
!
! c1geom
!
IF (dmpflg) WRITE (*,*) 'c1geom'
!
IF (acrsai(sr).LT.0.0.OR.acrsai(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' acrsai ',acrsai(sr)
!
IF (acrlai(sr).LT.0.0.OR.acrlai(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' acrlai ',acrlai(sr)
!
DO idx = 1,mncz
  IF (acrsaz(idx,sr).LT.0.0.OR.acrsaz(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,&
     &' acrsaz(',idx,') ',acrsaz(idx,sr)
!
  IF (acrlaz(idx,sr).LT.0.0.OR.acrlaz(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,&
     &' acrlaz(',idx,') ',acrlaz(idx,sr)
END DO
!
IF (acffcv(sr).LT.0.0.OR.acffcv(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' acffcv ',acffcv(sr)
!
IF (acfscv(sr).LT.0.0.OR.acfscv(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' acfscv ',acfscv(sr)
!
IF (acftcv(sr).LT.0.0.OR.acftcv(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' acftcv ',acftcv(sr)
!
! c1glob
!
IF (dmpflg) WRITE (*,*) 'c1glob'
!
IF (aczht(sr).LT.0.0.OR.aczht(sr).GT.3.0) WRITE (*,*) 'day ',day,' aczht ',     &
  & aczht(sr)
!
IF (aczrtd(sr).LT.0.0.OR.aczrtd(sr).GT.3.0) WRITE (*,*) 'day ',day,' aczrtd ',  &
  & aczrtd(sr)
!
IF (acm(sr).LT.0.0.OR.acm(sr).GT.tstmax) WRITE (*,*) 'day ',day,' acm ',acm(sr)
!
IF (acmst(sr).LT.0.0.OR.acmst(sr).GT.tstmax) WRITE (*,*) 'day ',day,' acmst ',  &
  & acmst(sr)
!
IF (acmrt(sr).LT.0.0.OR.acmrt(sr).GT.tstmax) WRITE (*,*) 'day ',day,' acmrt ',  &
  & acmrt(sr)
!
DO idx = 1,nslay(sr)
  IF (acmrtz(idx,sr).LT.0.0.OR.acmrtz(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,&
     &' acmrtz ',acmrtz(idx,sr)
END DO
!
IF (acrsai(sr).LT.0.0.OR.acrsai(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' acrsai ',acrsai(sr)
!
IF (acrlai(sr).LT.0.0.OR.acrlai(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' acrlai ',acrlai(sr)
!
DO idx = 1,mncz
  IF (acrsaz(idx,sr).LT.0.0.OR.acrsaz(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,&
     &' acrsaz ',acrsaz(idx,sr)
  IF (acrlaz(idx,sr).LT.0.0.OR.acrlaz(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,&
     &' acrlaz ',acrlaz(idx,sr)
END DO
!
IF (acffcv(sr).LT.0.0.OR.acffcv(sr).GT.1.0) WRITE (*,*) 'day ',day,' acffcv ',  &
  & acffcv(sr)
!
IF (acfscv(sr).LT.0.0.OR.acfscv(sr).GT.1.0) WRITE (*,*) 'day ',day,' acfscv ',  &
  & acfscv(sr)
!
IF (acftcv(sr).LT.0.0.OR.acftcv(sr).GT.1.0) WRITE (*,*) 'day ',day,' acffcv ',  &
  & acftcv(sr)
!
IF (acdstm(sr).LT.0.0.OR.acdstm(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' acdstm ',acdstm(sr)

! cldb2
!
IF (dmpflg) WRITE (*,*) 'c1db2'
!
IF (actopt(sr).LT.0.0.OR.actopt(sr).GT.40.0) WRITE (*,*) 'day ',day,' actopt ', &
  & actopt(sr)
!
IF (actmin(sr).LT.0.0.OR.actmin(sr).GT.20.0) WRITE (*,*) 'day ',day,' actmin ', &
  & actmin(sr)
!
IF (acfdla(sr).LT.0.0.OR.acfdla(sr).GT.1.0) WRITE (*,*) 'day ',day,' acfdla ',  &
  & acfdla(sr)
!
IF (acrdla(sr).LT.0.0.OR.acrdla(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' acrdla ',acrdla(sr)
!
IF (ac0caf(sr).LT.0.0.OR.ac0caf(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ac0caf ',ac0caf(sr)
!
IF (ac0psf(sr).LT.0.0.OR.ac0psf(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ac0psf ',ac0psf(sr)
!
DO idx = 1,2
  IF (ac0pt1(idx,sr).LT.0.0.OR.ac0pt1(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,&
     &' ac0pt1(',idx,') ',ac0pt1(idx,sr)
!
  IF (ac0pt2(idx,sr).LT.0.0.OR.ac0pt2(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,&
     &' ac0pt2(',idx,') ',ac0pt2(idx,sr)
!
  IF (ac0fd1(idx,sr).LT.0.0.OR.ac0fd1(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,&
     &' ac0fd1(',idx,') ',ac0fd1(idx,sr)
!
  IF (ac0fd2(idx,sr).LT.0.0.OR.ac0fd2(idx,sr).GT.1.0) WRITE (*,*) 'day ',day,   &
     &' ac0fd2(',idx,') ',ac0fd2(idx,sr)
END DO
!
IF (ac0ck(sr).LT.0.0.OR.ac0ck(sr).GT.1.0) WRITE (*,*) 'day ',day,' ac0ck ',     &
  & ac0ck(sr)
!
! c1mass
!
! ***      do 210 idx=1,mnsz
! ***      if (acmbgr(idx, sr).lt.tstmin.or.acmbgr(idx, sr).gt.tstmax)
! ***     &  write(*,*) 'day ',day,' acmbgr ', acmbgr(idx, sr)
! ***  210 continue
!
! c1db1
!
IF (dmpflg) WRITE (*,*) 'c1db1'
!
IF (acrcn(sr).LT.0.0.OR.acrcn(sr).GT.tstmax) WRITE (*,*) 'day ',day,' acrcn ',  &
  & acrcn(sr)
!
IF (actdtm(sr).LT.0.0.OR.actdtm(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' actdtm ',actdtm(sr)
!
IF (aczmrt(sr).LT.0.0.OR.aczmrt(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' aczmrt ',aczmrt(sr)
!
IF (aczmxc(sr).LT.0.0.OR.aczmxc(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' aczmxc ',aczmxc(sr)
!
IF (acrbe(sr).LT.0.0.OR.acrbe(sr).GT.tstmax) WRITE (*,*) 'day ',day,' acrbe ',  &
  & acrbe(sr)
!
IF (acrbed(sr).LT.0.0.OR.acrbed(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' acrbed ',acrbed(sr)
!
DO idx = 1,mncz
  IF (ac0lad(idx,sr).LT.0.0.OR.ac0lad(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,&
     &' ac0lad(',idx,') ',ac0lad(idx,sr)
!
  IF (ac0sad(idx,sr).LT.0.0.OR.ac0sad(idx,sr).GT.tstmax) WRITE (*,*) 'day ',day,&
     &' ac0sad(',idx,') ',ac0sad(idx,sr)
END DO
!
IF (acehu0(sr).LT.0.0.OR.acehu0(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' acehu0 ',acehu0(sr)
!
IF (ac0alf(sr).LT.0.0.OR.ac0alf(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ac0alf ',ac0alf(sr)
!
IF (ac0blf(sr).LT.0.0.OR.ac0blf(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ac0blf ',ac0blf(sr)
!
IF (ac0clf(sr).LT.0.0.OR.ac0clf(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ac0clf ',ac0clf(sr)
!
IF (ac0dlf(sr).LT.0.0.OR.ac0dlf(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ac0dlf ',ac0dlf(sr)
!
IF (ac0arp(sr).LT.0.0.OR.ac0arp(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ac0arp ',ac0arp(sr)
!
IF (ac0brp(sr).LT.0.0.OR.ac0brp(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ac0brp ',ac0brp(sr)
!
IF (ac0crp(sr).LT.0.0.OR.ac0crp(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ac0crp ',ac0crp(sr)
!
IF (ac0drp(sr).LT.0.0.OR.ac0drp(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ac0drp ',ac0drp(sr)
!
IF (ac0aht(sr).LT.0.0.OR.ac0aht(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ac0aht ',ac0aht(sr)
!
IF (ac0bht(sr).LT.0.0.OR.ac0bht(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ac0bht ',ac0bht(sr)
!
IF (ac0ssa(sr).LT.0.0.OR.ac0ssa(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ac0ssa ',ac0ssa(sr)
!
IF (ac0ssb(sr).LT.0.0.OR.ac0ssb(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ac0ssb ',ac0ssb(sr)
!
IF (ac0sla(sr).LT.0.0.OR.ac0sla(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ac0sla ',ac0sla(sr)
!
IF (ac0hue(sr).LT.0.0.OR.ac0hue(sr).GT.tstmax) WRITE (*,*) 'day ',day,          &
  & ' ac0hue ',ac0hue(sr)
!
IF (dmpflg) WRITE (*,*) 'end dbgdmp'
!
END SUBROUTINE dbgdmp

Project Documents/Source Code Original/Dbgdmp.f90