text:
!Write by Liao Yuanda
!
!###############################################################

module dou_ex

contains

    subroutine calcu_p_nearest( p, p_i_pl, p_i_mi, p_j_pl, p_j_mi, p_i_pl_j_mi, p_i_mi_j_pl, L )
        implicit none
        integer :: p, p_i_pl, p_i_mi, p_j_pl, p_j_mi, p_i_pl_j_mi, p_i_mi_j_pl, L
        integer :: i, j, i_pl, j_pl, i_mi, j_mi

        i = int((p-1)/L)
        j = mod(p-1,L)
        i_pl = mod(i+1,L)
        j_pl = mod(j+1,L)
        if (i==0) then
            i_mi = L-1
        else
            i_mi = i-1
        end if
        if (j==0) then
            j_mi = L-1
        else
            j_mi = j-1
        end if

        p_i_pl = i_pl*L+j+1
        p_i_mi = i_mi*L+j+1
        p_j_pl = i*L+j_pl+1
        p_j_mi = i*L+j_mi+1
        p_i_pl_j_mi = i_pl*L+j_mi+1
        p_i_mi_j_pl = i_mi*L+j_pl+1

    end subroutine calcu_p_nearest

    subroutine calcu_H( L, N, M, H, t )

        implicit none
        integer :: L, N, M, i, j
        integer :: p, p_i_pl, p_i_mi, p_j_pl, p_j_mi, p_i_pl_j_mi, p_i_mi_j_pl
        complex*16  :: H(M, M)
		real*8 :: t

        do i = 1, M
            do j = 1, M
                H(i,j) = 0.0
            end do
        end do

        do i = 0, L-1, 1
            do j = 0, L-1, 1
                p = i*L+j+1
                call calcu_p_nearest( p, p_i_pl, p_i_mi, p_j_pl, p_j_mi, p_i_pl_j_mi, p_i_mi_j_pl, L )

                H(p, p_i_pl) = -t
                H(p, p_i_mi) = -t
                H(p, p_j_pl) = -t
                H(p, p_j_mi) = -t
                H(p, p_i_pl_j_mi) = -t
                H(p, p_i_mi_j_pl) = -t

                H(p+N, p_i_pl+N) = -t
                H(p+N, p_i_mi+N) = -t
                H(p+N, p_j_pl+N) = -t
                H(p+N, p_j_mi+N) = -t
                H(p+N, p_i_pl_j_mi+N) = -t
                H(p+N, p_i_mi_j_pl+N) = -t
            end do
        end do
    end subroutine calcu_H

    subroutine pem_sparse( H, val1, val2, colind, rowptr , M, nonzeros)
            implicit none
            integer :: M, nonzeros, colind(nonzeros), rowptr(M+1), i, j, k, num_row
            complex*16 :: H(M, M)
            real*8 :: val1(nonzeros), val2(nonzeros)
            k = 0
            do i = 1, M
                rowptr(i) = k

                do j = 1, M
                    if ( H(i,j) /= (0.0,0.0)) then
                        k = k+1

                        val1(k) = real(H(i,j))
                        val2(k) = aimag(H(i,j))
                        colind(k) = j-1
                    end if
                end do
            end do
            rowptr(M+1) = nonzeros
			write(*,*) k, nonzeros
    end subroutine pem_sparse

	subroutine pem_rescale( H, a, b, M)
		implicit none
		integer :: M, i, j
		complex*16 :: H(M,M)
		real*8 :: a, b
		do i = 1,M
			H(i,i) = H(i,i)-b
        	do j = 1,M
				H(i,j) = H(i,j)/a
        	end do
    	end do
	end subroutine pem_rescale
end module dou_ex

program skyrmionlattice
    use dou_ex
    implicit none
    !#########################################
    !L, size of lattice
    !N = L*L, num of lattice
    !t, J_para, the parameter if H
    !##########################################
    integer, parameter :: L = 60, N = L*L, M = 2*N, nonzeros = 7*M, cutoff = 800, num_x = 100
    real*8, parameter :: t = 1.0
    integer, dimension(nonzeros) :: colind
    integer, dimension(M+1) :: rowptr
    real*8, dimension(nonzeros) :: val1, val2
	real*8, dimension(cutoff) :: miun_pem
	!real*8, dimension(num_x) :: stateden_pem_integral
    !real*8, dimension(cutoff) :: miun_tpem, miun_pem, miun_ev
    !real*8, dimension(M) :: eigv
    !real*8, dimension(num_x) :: stateden_ev, stateden_pem
    integer :: i, j, interval
    real*8 :: Emax, Emin, a, b, weight, beta, miu, t1, t2
    complex*16, dimension(M,M) :: H
    Emax = 3*t
    Emin = -6*t
    a = (Emax-Emin)/2.0
    b = (Emax+Emin)/2.0
	beta = 10.0*t
	miu = 0.7424*t
	!interval = 100
    !##########################
    call cpu_time(t1)
    write(*,*) 'Begin at:', t1
    !######################
	!open(unit = 15, file = 'eigv.in')
    open(unit = 14, file = 'miun_pem.out')
	!open(unit = 13, file = 'dos_ev.out')
	!open(unit = 17, file = 'dos_pem.out')
	!open(unit = 18, file = 'dos_pem_integral.out')
	!do i = 1, M
	!	read(15,*) eigv(i)
	!end do
	!close(15)
    call calcu_H( L, N, M, H, t )
	call pem_rescale( H, a, b, M)
    call pem_sparse( H, val1, val2, colind, rowptr , M, nonzeros)

	!call pem_statedensity( num_x, cutoff, M, nonzeros, val1, val2, colind, rowptr, stateden_pem )
	!call pem_statedensity_integral( num_x, interval, cutoff, M, nonzeros, val1, val2, colind, rowptr, stateden_pem_integral)
	!call pem_particle_density( cutoff, M, nonzeros, val1, val2, colind, rowptr, beta, miu, a, b, weight )
	call pem_moments( cutoff, M, nonzeros, val1, val2, colind, rowptr, miun_pem)
	!call pem_logweight( cutoff, M, nonzeros, val1, val2, colind, rowptr, 0.0, 0.0, a, b, weight )
	!call pem_test( cutoff, M, nonzeros, val1, val2, colind, rowptr, miun_tpem, miun_pem, miun_ev, eigv)
	!call pem_ev_dos( cutoff, num_x, M, eigv, stateden_ev)
	!write(*,*) weight
    !do i = 1, num_x
		!write(13,*) stateden_ev(i)
		!write(17,*) stateden_pem(i)
		!write(18,*) stateden_pem_integral(i)
    !end do
	!write(*,*) weight
    do i = 1, cutoff
		!write(14,*) miun_tpem(i),miun_pem(i),miun_ev(i)
		write(14,*) miun_pem(i)
    end do
    !close(14)
    !close(13)
    !close(17)
    !close(18)
    !##########################
    call cpu_time(t2)
    write(*,*) 'End at:', t2
    !######################
    write(*,*) 'Timecost:', t2-t1
end program skyrmionlattice

max_stars_repo_name: Greatliao/skyrmions

max_issues_repo_name: Greatliao/skyrmions

max_forks_repo_name: Greatliao/skyrmions


text:
	FUNCTION PR_TLCL  ( tmpc, dwpc )
C************************************************************************
C* PR_TLCL 								*
C*									*
C* This function computes temperature at the Lifted Condensation	*
C* Level for a parcel of air given TMPC and  DWPC.  The following 	*
C* equation is used:							*
C*									*
C*  TLCL = [ 1 / ( 1 / (DWPK-56) + ALOG (TMPK/DWPK) / 800 ) ] + 56	*
C*									*
C* Bolton.								*
C*									*
C* REAL PR_TLCL  ( TMPC, DWPC )						*
C*									*
C* Input parameters:							*
C*	TMPC		REAL    	Temperature in Celsius		*
C*	DWPC		REAL		Dewpoint in Celsius		*
C*									*
C* Output parameters:							*
C*	PR_TLCL		REAL    	LCL temperature in Kelvin	*
C**									*
C* Log:									*
C* M. Goodman/RDS	8/84	Original source				*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC	8/88	Modified documentation, made -273 real  *
C* G. Krueger/EAI        4/96   Replaced C->K constant with TMCK	*
C* T. Lee/GSC		 8/97	Rearranged equation			*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
C*      Check for missing or out-of-bounds values.
C
	IF  ( ( ERMISS ( tmpc ) ) .or. ( ERMISS ( dwpc ) ) .or.
     +        ( tmpc .lt. -TMCK ) .or. ( dwpc .lt. -TMCK ) )  THEN
	    PR_TLCL = RMISSD
	  ELSE
	    tmpk = PR_TMCK ( tmpc )
	    dwpk = PR_TMCK ( dwpc )
	    PR_TLCL = ( 800. * ( dwpk - 56. ) / ( 800. + ( dwpk - 56. )*
     +			ALOG ( tmpk / dwpk ) ) ) + 56.
	END IF
C*
	RETURN
	END

ext: f

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
great(d1,p1).
great(p1,ll1).
great(q1,dd1).
great(z1,r1).
great(j1,ll1).
great(c1,z1).
great(e1,i1).
great(dd1,t1).
great(jj1,ff1).
great(o1,ll1).
great(j1,p1).
great(l1,r1).
great(u1,o1).
great(d1,b1).
great(g1,y1).
great(q1,y1).
great(g1,j1).
great(h1,b1).
great(bb1,aa1).

max_stars_repo_name: manoelfranca/cilppp

max_issues_repo_name: manoelfranca/cilppp

max_forks_repo_name: manoelfranca/cilppp


module ElementPtrM
  use UtilitiesM
  use DebuggerM

  use NodeM
  use NodePtrM

  use GeometryM

  use IntegratorPtrM

  use LeftHandSideM

  use ProcessInfoM

  use SourceM
  use SourcePtrM

  use ElementM

  implicit none

  private
  public :: ElementPtrDT

  type :: ElementPtrDT
     class(ElementDT), pointer :: ptr
   contains
     procedure, public :: assignGeometry
     procedure, public :: assignNode
     procedure, public :: assignSourceOne
     procedure, public :: assignSourceMulti
     generic           :: assignSource => assignSourceOne, assignSourceMulti

     procedure, public :: getID
     procedure, public :: getnNode
     procedure, public :: getIntegrator
     procedure, public :: getNode
     procedure, public :: getNodeID
     procedure, public :: hasSourceOneSource
     procedure, public :: hasSourceMultiSource
     generic           :: hasSource => hasSourceOneSource, hasSourceMultiSource

     procedure, public :: calculateLocalSystem
     procedure, public :: calculateLHS
     procedure, public :: calculateRHS
     procedure, public :: calculateResults
  end type ElementPtrDT

contains

  subroutine assignGeometry(this, geometry)
    implicit none
    class(ElementPtrDT)      , intent(inout) :: this
    class(GeometryDT), target, intent(in)    :: geometry
    call this%ptr%assignGeometry(geometry)
  end subroutine assignGeometry

  subroutine assignNode(this, index, node)
    implicit none
    class(ElementPtrDT)     , intent(inout) :: this
    integer(ikind)          , intent(in)    :: index
    type(NodeDT)    , target, intent(in)    :: node
    call this%ptr%assignNode(index, node)
  end subroutine assignNode

  subroutine assignSourceOne(this, source)
    implicit none
    class(ElementPtrDT)     , intent(inout) :: this
    class(SourceDT) , target, intent(in)    :: source
    call this%ptr%assignSourceOne(source)
  end subroutine assignSourceOne

  subroutine assignSourceMulti(this, iSource, source)
    implicit none
    class(ElementPtrDT)     , intent(inout) :: this
    integer(ikind)          , intent(in)    :: iSource
    class(SourceDT) , target, intent(in)    :: source
    call this%ptr%assignSourceMulti(iSource, source)
  end subroutine assignSourceMulti

  integer(ikind) pure function getID(this)
    implicit none
    class(ElementPtrDT), intent(in) :: this
    getID = this%ptr%getID()
  end function getID

  integer(ikind) pure function getnNode(this)
    implicit none
    class(ElementPtrDT), intent(in) :: this
    getnNode = this%ptr%getnNode()
  end function getnNode

  type(IntegratorPtrDT) function getIntegrator(this)
    implicit none
    class(ElementPtrDT), intent(inout) :: this
    getIntegrator = this%ptr%getIntegrator()
  end function getIntegrator

  type(NodePtrDT) function getNode(this, iNode)
    implicit none
    class(ElementPtrDT), intent(inout) :: this
    integer(ikind)     , intent(in)    :: iNode
    getNode = this%ptr%getNode(iNode)
  end function getNode

  integer(ikind) pure function getNodeID(this, iNode)
    implicit none
    class(ElementPtrDT), intent(in) :: this
    integer(ikind)     , intent(in) :: iNode
    getNodeID = this%ptr%getNodeID(iNode)
  end function getNodeID

  logical function hasSourceOneSource(this)
    implicit none
    class(ElementPtrDT), intent(inout) :: this
    hasSourceOneSource = this%ptr%hasSourceOneSource()
  end function hasSourceOneSource

  logical function hasSourceMultiSource(this, iSource)
    implicit none
    class(ElementPtrDT), intent(inout) :: this
    integer(ikind)     , intent(in)    :: iSource
    hasSourceMultiSource = this%ptr%hasSourceMultiSource(iSource)
  end function hasSourceMultiSource

  subroutine calculateLocalSystem(this, processInfo, lhs, rhs)
    implicit none
    class(ElementPtrDT)                              , intent(inout) :: this
    type(ProcessInfoDT)                              , intent(inout) :: processInfo
    type(LeftHandSideDT)                             , intent(inout) :: lhs
    real(rkind)         , dimension(:)  , allocatable, intent(inout) :: rhs
    call this%ptr%calculateLocalSystem(processInfo, lhs, rhs)
  end subroutine calculateLocalSystem

  subroutine calculateLHS(this, processInfo, lhs)
    implicit none
    class(ElementPtrDT) , intent(inout) :: this
    type(ProcessInfoDT) , intent(inout) :: processInfo
    type(LeftHandSideDT), intent(inout) :: lhs
    call this%ptr%calculateLHS(processInfo, lhs)
  end subroutine calculateLHS

  subroutine calculateRHS(this, processInfo, rhs)
    implicit none
    class(ElementPtrDT)                           , intent(inout) :: this
    type(ProcessInfoDT)                           , intent(inout) :: processInfo
    real(rkind)        , dimension(:), allocatable, intent(inout) :: rhs
    call this%ptr%calculateRHS(processInfo, rhs)
  end subroutine calculateRHS

  subroutine calculateResults(this, processInfo, resultMat)
    implicit none
    class(ElementPtrDT)                               , intent(inout) :: this
    type(ProcessInfoDT)                               , intent(inout) :: processInfo
    real(rkind)        , dimension(:,:,:), allocatable, intent(inout) :: resultMat
    call this%ptr%calculateResults(processInfo, resultMat)
  end subroutine calculateResults

end module ElementPtrM


!
! Fortran FastCGI stack
! Based on Fortran FastCGI by Ricolindo.Carino@gmail.com and arjen.markus895@gmail.com
!
! Requires:
!    - the FLIBS modules cgi_protocol and fcgi_protocol
!    - the FastCGI library
!

program app

    use fcgi_protocol

    implicit none

    type(DICT_STRUCT), pointer  :: dict => null() ! Initialisation is important!
    logical                     :: stopped = .false. ! set to true in respond() to terminate program
    integer                     :: unitNo ! unit number  for a scratch file
    character(len=20)           :: mime = 'text/plain' ! mime type

    ! open scratch file
    open(newunit=unitNo, status='scratch')

    ! wait for environment variables from webserver
    do while (fcgip_accept_environment_variables() >= 0)

        ! build dictionary from GET or POST data, environment variables
        call fcgip_make_dictionary( dict, unitNo )

        call respond(dict, unitNo, stopped, mime)

        call fcgip_put_file( unitNo, mime )

        ! terminate?
        if (stopped) exit

    end do !  while (fcgip_accept_environment_variables() >= 0)

    close(unitNo)

    ! webserver will return an error since this process will now terminate
    unitNo = fcgip_accept_environment_variables()

contains
    subroutine respond ( dict, unitNo, stopped, mime )

        type(DICT_STRUCT), pointer        :: dict
        integer, intent(in)               :: unitNo
        logical, intent(out)              :: stopped
        character(len=20), intent(out)    :: mime

        ! the script name
        character(len=80)  :: scriptName, query

        ! retrieve script name (key=DOCUMENT_URI) from dictionary
        call cgi_get( dict, "DOCUMENT_URI", scriptName )

        select case (trim(scriptName))
            case ('/plaintext')
                mime = 'text/plain'
                write(unitNo, AFORMAT) 'Hello, World!'
            case DEFAULT
        end select

        return

    end subroutine respond

end program app


text:
!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      subroutine dhnlun(istart,lun)

!     Deltares Software Centre

!     function : gives next free unit number, starting at istart till istart + 98

!     declaration of the arguments

      integer               , intent(in)    :: istart       ! start looking from here
      integer               , intent(out)   :: lun          ! next free unit number

!     local declaration

      integer                               :: ilun         ! loop counter
      logical                               :: lopen        ! opened indicator

      lun = 0
      do ilun = istart, istart + 98
         inquire(ilun,opened=lopen)
         if ( .not. lopen ) then
            lun = ilun
            exit
         endif
      enddo

      return
      end

max_stars_repo_name: liujiamingustc/phd

max_issues_repo_name: liujiamingustc/phd

max_forks_repo_name: liujiamingustc/phd


text:
program case_02
    implicit none

    ! local variable declaration
    integer :: marks
    marks = 81

    select case (marks)

       case (91:100)
          print*, "Excellent!"

       case (81:90)
          print*, "Very good!"

       case (71:80)
          print*, "Well done!"

       case (61:70)
          print*, "Not bad!"

       case (41:60)
          print*, "You passed!"

       case (:40)
          print*, "Better try again!"

       case default
          print*, "Invalid marks"

    end select
    print*, "Your marks are ", marks

    ! case default at the top
    select case (marks)

       case default
          print*, "Invalid marks"

       case (91:100)
          print*, "Excellent!"

       case (81:90)
          print*, "Very good!"

       case (71:80)
          print*, "Well done!"

       case (61:70)
          print*, "Not bad!"

       case (41:60)
          print*, "You passed!"

       case (:40)
          print*, "Better try again!"

    end select
    print*, "Your marks are ", marks

    ! case default in the middle
    select case (marks)

       case (91:100)
          print*, "Excellent!"

       case (81:90)
          print*, "Very good!"

       case default
          print*, "Invalid marks"

       case (71:80)
          print*, "Well done!"

       case (61:70)
          print*, "Not bad!"

       case (41:60)
          print*, "You passed!"

       case (:40)
          print*, "Better try again!"

    end select
    print*, "Your marks are ", marks

end program

max_stars_repo_name: Thirumalai-Shaktivel/lfortran

max_issues_repo_name: Thirumalai-Shaktivel/lfortran

max_forks_repo_name: Thirumalai-Shaktivel/lfortran


text:
      subroutine config_satellite_lvd(istatus)
c
cdoc  Reads static/satellite_lvd.nl file.

      character nest7grid*150
      include 'satellite_dims_lvd.inc'
      include 'satellite_common_lvd.inc'
      include 'satellite_namelist_lvd.cmn'
      include 'grid_fname.cmn'

      integer num_sat
      integer num_types(maxsat)
      integer num_channels(maxtype,maxsat)
      integer i_qc_sat_flag(maxchannel*maxtype*maxsat)

      character*6   csatid(maxsat)
      character*3   csattypes(maxtype*maxsat)
      character*3   cchanneltypes(maxchannel*maxtype*maxsat)
      character*200 cpath2sat(maxtype*maxsat)
      integer   max_files
      parameter (max_files=20000)

      character*200 c_filenames(max_files)

      integer istatus

      include 'satdata_lvd.for'

      istatus = 0

!     Initialize
      cchanneltypes = '   '

      write(6,*)' Reading LVD namelist in config_satellite_lvd'

      call get_directory(grid_fnam_common,nest7grid,len_dir)
      nest7grid = nest7grid(1:len_dir)//'/satellite_lvd.nl'
      open(1,file=nest7grid,status='old',err=900)
      read(1,satellite_lvd_nl,err=901)
      close(1)
      istatus = 1

      do i=1,maxchannel*maxtype*maxsat
          call s_len(cchanneltypes(i),lenc)
          if(lenc .gt. 0)then
              write(6,*)' i,cchanneltypes(i) ',i,trim(cchanneltypes(i))
          endif
      enddo ! i

      call conf_isjtkc(maxsat,maxtype,maxchannel,
     &csatid,csattypes,cchanneltypes,cpath2sat,
     &i_qc_sat_flag,istatus)

      if(.true.)then

      is=0
      kk=0
      do i=1,maxsat
       if(isats(i).eq.1)is=is+1
      enddo
      print*
      print*,'Number of satellites to process: ',is
      do i=1,maxsat
       if(isats(i).eq.1)then
        print*
        print*,'Sat ',i,' ID: ',c_sat_id(i)
        print*,'================================='
       endif
       do j=1,maxtype
        if(itypes(j,i).eq.1)then
         print*,'  Type: ',j, ' = ',c_sat_types(j,i)
         print*,'  ***************************************'
         print*,'  Attributes of this satellite and type: '
         print*,'  ---------------------------------------'
         print*,'   Latin/Lap/Lov: ',r_latin(j,i),r_lap(j,i),r_lov(j,i)
         print*,'   vis/ir(x/y) res (km): ', r_resolution_x_vis(j,i),
     &r_resolution_y_vis(j,i),r_resolution_x_ir(j,i),r_resolution_y_ir
     &(j,i)
         print*,'  ---------------------------------------'
         do k=1,maxchannel
          if(ichannels(k,j,i).eq.1)then
           print*,'   Chn ',k,' = ',c_channel_types(k,j,i)(1:3)
           print*,'   Path      = ',TRIM(path_to_raw_sat(k,j,i))
           if(kk.lt.1)then
            call get_file_names(path_to_raw_sat(k,j,i)
     1,numoffiles,c_filenames, max_files,istatus)
c           print*,'filenames: ',c_filenames(1:numoffiles)
            if(numoffiles.le.0)then
             print*
             print*,'!!!! Error: No data in given path'
             print*,'Path: ',TRIM(path_to_raw_sat(k,j,i))
             print*
             return
            endif
            kk=10
           endif
          endif
         enddo
        endif
       enddo
      enddo

      endif

      return

 900  print*,'error opening file ',nest7grid
      return
 901  print*,'error reading satellite_nl in ',nest7grid
      write(*,satellite_lvd_nl)

c----- don't worry about the rep namelist atm.

      return

      print*,'**************************************************'
      print*,'Now using repository version: satellite_lvd_rep.nl'
      print*,'**************************************************'

      nest7grid = nest7grid(1:len_dir)//'/satellite_lvd_rep.nl'
      open(1,file=nest7grid,status='old',err=902)
      read(1,satellite_lvd_nl,err=903)
      close(1)
      istatus = 1
      return

 902  print*,'error opening file ',nest7grid
      return
 903  print*,'error reading satellite_lvd_rep.nl in ',nest7grid
      write(*,satellite_lvd_nl)
      return
      end
c
c =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
c
      subroutine get_sat_sounder_info(n_sndr,
     +c_sndr_id,n_sndr_channels,path_to_sat_sounder,
     +channel_wavelength_u,imsng_sndr_pix,pct_req_lsr,
     +istatus)
c
cdoc  Reads static/sat_sounder.nl file.

      include 'lsr_dims.inc'
      include 'grid_fname.cmn'       !grid_fnam_common

      integer len_dir
      integer n_sndr
      integer n_sndr_channels
      integer imsng_sndr_pix
      integer istatus
      character*6   c_sndr_id(max_sat)
      character*150 nest7grid
      character*200 path_to_sat_sounder(max_sat)

      real channel_wavelength_u(max_ch,max_sat)
      real pct_req_lsr

      namelist /satellite_sounder_nl/ n_sndr,c_sndr_id,path_to_sat_sound
     +er,n_sndr_channels,channel_wavelength_u,imsng_sndr
     +_pix,pct_req_lsr

      call get_directory(grid_fnam_common,nest7grid,len_dir)

      nest7grid = nest7grid(1:len_dir)//'/sat_sounder.nl'

      open(1,file=nest7grid,status='old',err=900)
      read(1,satellite_sounder_nl,err=901)
      close(1)

      istatus = 1
      return
 900  print*,'error opening file ',nest7grid
      stop
 901  print*,'error reading satellite_sounder_nl in ',nest7grid
      write(*,satellite_sounder_nl)
      stop
      end
c
c-----------------------------------------------------------
c
      subroutine get_balance_nl(lrunbal,adv_anal_by_t_min
     .           ,cpads_type,incl_clom,setdelo0
     .           ,c_erru, c_errub, c_errphi, c_errphib, c_delo
     .           ,comega_smooth, erf, itmax
     .           ,istatus)
c
cdoc  Reads static/balance.nl file.

      implicit none

      integer    istatus
      integer    len_dir, itmax
      integer    adv_anal_by_t_min
      logical    lrunbal
      logical    incl_clom
      logical    setdelo0
      character  nest7grid*150
      character  cpads_type*3
      real c_erru, c_errub, c_errphi, c_errphib, c_delo, comega_smooth
      real erf

      include   'grid_fname.cmn'       !grid_fnam_common

      namelist /balance_nl/lrunbal,adv_anal_by_t_min,cpads_type
     1        ,incl_clom,setdelo0,erf,itmax
     1        ,c_erru, c_errub, c_errphi, c_errphib, c_delo
     1        ,comega_smooth

      istatus = 0

      call get_directory(grid_fnam_common,nest7grid,len_dir)
      if(nest7grid(len_dir:len_dir).ne.'/') then
        len_dir=len_dir+1
        nest7grid(len_dir:len_dir)='/'
      endif

      nest7grid = nest7grid(1:len_dir)//'balance.nl'

      incl_clom=.true.

      open(1,file=nest7grid,status='old',err=900)
      read(1,balance_nl,err=901)
      close(1)
      return
900   print*,'error opening file ',nest7grid
      stop
901   print*,'error reading balance.nl in ',nest7grid
      write(*,balance_nl)
      stop
      end
c
c-----------------------------------------------------------
c
      subroutine get_sfcqc_nl(lrunqc,istatus)
c
cdoc  Reads static/balance.nl file.

      implicit none

      integer    istatus
      integer    len_dir
      logical    lrunqc
      character  nest7grid*150

      include   'grid_fname.cmn'       !grid_fnam_common

      namelist /sfc_qc_nl/lrunqc

      istatus = 0

      call get_directory(grid_fnam_common,nest7grid,len_dir)
      if(nest7grid(len_dir:len_dir).ne.'/') then
        len_dir=len_dir+1
        nest7grid(len_dir:len_dir)='/'
      endif

      nest7grid = nest7grid(1:len_dir)//'sfc_qc.nl'

      open(1,file=nest7grid,status='old',err=900)
      read(1,sfc_qc_nl,err=901)
      close(1)
      istatus = 1
      return
900   print*,'error opening file ',nest7grid
      stop
901   print*,'error reading sfc_qc.nl in ',nest7grid
      write(*,sfc_qc_nl)
      stop
      end
c
c ---------------------------------------------------------
c
      subroutine mosaic_radar_nl(c_radar_mosaic_type,n_radars,
     & c_radar_ext,i_window,mosaic_cycle_time,imosaic_3d,
     & n_radars_wideband,n_radars_narrowband,istatus)
c
cdoc  Reads static/radar_mosaic.nl file

      include    'radar_mosaic_dim.inc'
      include    'grid_fname.cmn'              !grid_fnam_common

      integer    istatus
      integer    len_dir
      integer    n_radars
      integer    i_window
      integer    imosaic_3d
      character  c_radar_mosaic_type*3
      character  c_radar_ext(max_radars_mosaic)*4
      character  nest7grid*150

      namelist /radar_mosaic_nl/c_radar_mosaic_type,n_radars,
     & c_radar_ext,i_window,mosaic_cycle_time,imosaic_3d,
     & n_radars_wideband,n_radars_narrowband

      istatus = 0

      call get_directory(grid_fnam_common,nest7grid,len_dir)
      if(nest7grid(len_dir:len_dir).ne.'/') then
        len_dir=len_dir+1
        nest7grid(len_dir:len_dir)='/'
      endif

      nest7grid = nest7grid(1:len_dir)//'radar_mosaic.nl'

      open(1,file=nest7grid,status='old',err=900)
      read(1,radar_mosaic_nl,err=901)
      close(1)
      return
900   print*,'error opening file ',nest7grid
      stop
901   print*,'error reading radar_mosaic.nl in ',nest7grid
      write(*,radar_mosaic_nl)
      stop
      end
c
c -------------------------------------------------------------
c
      subroutine get_background_info(bgpaths,bgmodels
     +,forecast_length
     +,use_analysis
     +,use_forecast
     +,cmodel,itime_inc,smooth_fields,luse_sfc_bkgd
     +,ntmin,ntmax
     +,lgb_only)

cdoc reads static/background.nl

      implicit none
      include 'bgdata.inc'
      include 'grid_fname.cmn'             !grid_fnam_common

      character*150 nest7grid
      character*256 bgpaths(maxbgmodels)
      character*132 cmodel(maxbgmodels)
      integer bgmodels(maxbgmodels), len_dir
      integer forecast_length
      integer itime_inc,ntmin,ntmax
      logical luse_sfc_bkgd
      logical use_analysis
      logical use_forecast
      logical smooth_fields
      logical lgb_only
      namelist /background_nl/bgpaths,bgmodels
     +,forecast_length
     +,use_analysis
     +,use_forecast
     +,cmodel,itime_inc,smooth_fields,luse_sfc_bkgd
     +,ntmin,ntmax
     +,lgb_only

      use_forecast = .true.
      smooth_fields = .false.
      ntmin = -1
      ntmax = +1
      call get_directory(grid_fnam_common,nest7grid,len_dir)
      if(nest7grid(len_dir:len_dir).ne.'/') then
        len_dir=len_dir+1
        nest7grid(len_dir:len_dir)='/'
      endif
      nest7grid = nest7grid(1:len_dir)//'background.nl'

      open(1,file=nest7grid(1:len_dir+13),status='old',err=900)
      read(1,background_nl,err=901)
      close(1)
      return
 900  print*,'error opening file ',nest7grid
      stop
 901  print*,'error reading background_nl in ',nest7grid
      write(*,background_nl)
      stop
      end
c
c --- OSSE namelist reader ---
c
      subroutine get_osse_information(path_to_model,
     1                                cmodel,
     1                                c_obs_types,
     1                                n_sim_obs,
     1                                c_simob_fnames,
     1                                a9_time_init,
     1                                a4_time_fcst,
     1                                ifcst_intrvl,
     1                                isim_time_hr,
     1                                istatus)
c
cdoc  Reads static/osse.nl file.

      implicit none

      include 'grid_fname.cmn'                 !grid_fnam_common
      include 'osse.inc'

      integer        istatus
      integer        len_dir
      integer        i,n_sim_obs
      integer        ifcst_intrvl
      integer        isim_time_hr
      integer        n_simfiles

      integer        nsimobs
      data           nsimobs/0/
      save           nsimobs

      character      nest7grid*150
      character      path_to_model*150
      character      c_obs_types(maxobtype)*15
      character      c_simob_fnames(nsimfiles)*50
      character      a9_time_init*9
      character      a4_time_fcst*4
      character      cmodel*10

      namelist /osse_nl/path_to_model,cmodel,c_obs_types
     1,c_simob_fnames,a9_time_init,a4_time_fcst,ifcst_intrvl
     1,isim_time_hr

      istatus = 0

      call get_directory(grid_fnam_common,nest7grid,len_dir)
      if(nest7grid(len_dir:len_dir).ne.'/') then
        len_dir=len_dir+1
        nest7grid(len_dir:len_dir)='/'
      endif

      do i = 1,maxobtype
         c_obs_types(i) = ' '
      enddo
      do i = 1,nsimfiles
         c_simob_fnames(i) = ' '
      enddo

      nest7grid = nest7grid(1:len_dir)//'osse.nl'
      print*,'nest7grid = ',nest7grid(1:len_dir+7)

      open(1,file=nest7grid,status='old',err=900)
      read(1,osse_nl,err=901)
      close(1)

      if(nsimobs.eq.0)then
         do i = 1,maxobtype
            if(c_obs_types(i).ne.' ')then
               n_sim_obs = n_sim_obs + 1
            endif
         enddo
         nsimobs=n_sim_obs
      endif
      n_sim_obs=nsimobs
      print*,'n_sim_obs types from namelist= ',n_sim_obs
      istatus = 1

      return

900   print*,'error opening file ',nest7grid
      stop
901   print*,'error reading osse.nl in ',nest7grid
      write(*,osse_nl)
      stop
      end
c
c----------------------------------------
c
       subroutine get_gridnl(mode)
       implicit none
       integer mode
       integer len
       integer istatus
       character*256 directory
       character*256 fname
       character*200 cdataroot
       character*10  c10_grid_fname
       namelist /grid_nl/ mode

       mode = 0
       call find_domain_name(cdataroot,c10_grid_fname,istatus)
       if(istatus.ne.1)then
          print*,'Error returned from find_domain_name'
          return
       endif
       call get_directory(c10_grid_fname,directory,len)
       fname = directory(1:len)//'grid.nl'
       open(3,file=fname,status='old',err=101)
       read(3,grid_nl,err=101,end=101)
       close(3)

101    return
       end
c
c --------------------------------------------------------------
c
       subroutine read_verif_nl(type_obs,path_to_raw_profiler,
     1path_to_raw_sounding, raob_process_lag,  raob_process_lag_bal,
     1                          max_verif, verif_output_dir,
     1                          verif_missing_data, n_verif, istatus)

       implicit none

       include 'grid_fname.cmn'                          !grid_fnam_common

       integer          max_verif
       character*1	type_obs
       character*150	path_to_raw_profiler
       character*150	path_to_raw_sounding
       integer	raob_process_lag_Bal
       integer	raob_process_lag
       integer          n_verif
       integer          i,len
       character*150	verif_output_dir(4)
       real		verif_missing_data
       integer		istatus

       namelist /verif_nl/ type_obs,path_to_raw_profiler,
     1path_to_raw_sounding, raob_process_lag, raob_process_lag_bal,
     1                  verif_output_dir,
     1                  verif_missing_data

       character*150    static_dir,filename
       integer		len_dir

       istatus = 0
       call get_directory(grid_fnam_common,static_dir,len_dir)

       filename = static_dir(1:len_dir)//'/verif.nl'

       open(1,file=filename,status='old',err=900)
       read(1,verif_nl,err=901)
       close(1)

       n_verif=0
       do i=1,max_verif
          call s_len(verif_output_dir(i),len)
          if(len.gt.0)then
             n_verif=n_verif+1
          endif
       enddo
       if(n_verif.le.0)then
          print*,'Error! Check namelist verif.nl variable'
          print*,'verif_output_dir. It appears to be empty'
          return
       endif
c      print*,'Number of verification types from verif.nl: ',n_verif
c      call s_len(verif_output_dir(1),len)
c      do i=1,n_verif
c         print*,i,' ',verif_output_dir(i)(1:len)
c      enddo

       istatus = 1
       return

  900  print*,'error opening file ',filename
       return

  901  print*,'error reading verif_nl in ',filename
       write(*,verif_nl)
       return

       end

c
c --------------------------------------------------------------
c
       subroutine get_laps_redp(redp_lvl_out,istatus)

       use mem_namelist, ONLY: read_namelist_laps
       use mem_namelist, ONLY: redp_lvl

       character*150 static_dir,filename

!      Read global parameters into module memory structure
       call get_directory('static',static_dir,len_dir)
       filename = static_dir(1:len_dir)//'/nest7grid.parms'
       call read_namelist_laps('lapsparms',filename)

       redp_lvl_out = redp_lvl

       istatus = 1
       return

       end

c ------------------------------------------------------------------
c New routine that configures the satellite information needed in
c software using a limited satellite lvd namelist file
c J. Smart 5/07
c
      subroutine conf_isjtkc(nsdim,ntdim,ncdim,
     &csatid,csattypes,cchanneltypes,cpath2sat,
     &i_qc_sat_flag,istatus)

      include 'satellite_dims_lvd.inc'
      include 'satellite_common_lvd.inc'
      include 'satdata_lvd_table.for'

      integer       i_qc_sat_flag(ncdim*ntdim*nsdim)
      character*6   csatid(nsdim)
      character*3   csattypes(ntdim*nsdim)
      character*3   cchanneltypes(ncdim*ntdim*nsdim)
      character*200 cpath2sat(ntdim*nsdim)

      print*
      print*,'Start conf_isjtkc...'

!     Determine satellites with help of 'satdata_lvd_table'
      ISATS=0
      do i=1,nsats
        do js = 1,maxsat
          if(trim(csatid(i)).eq.trim(satellite_ids(js)))then
            ISATS(js)=1
            c_sat_id(js)=csatid(i)
          endif
        enddo ! js
      enddo ! i

!     Determine satellite types with help of 'satdata_lvd_table'
      ITYPES=0
      jj=0
      do i=1,nsats
        do js = 1,maxsat
          if(trim(csatid(i)).eq.trim(satellite_ids(js)))then
            write(6,*)
            write(6,*)' Match csatid/satellite_ids/ntypes'
     1                                  ,i,js,ntypes(i),csatid(i)
            do j=1,ntypes(i)
              jj=jj+1
              do it = 1,4
                if(csattypes(jj).eq.satellite_types(it,js))then !raw lat-lon > could be (likely is) netcdf format
                  write(6,*)' Match csattypes/satellite_types     '
     1                                              ,j,it,csattypes(jj)
                  ITYPES(it,js)=1
                  c_sat_types(it,js)=csattypes(jj)
                else
                  write(6,*)' No match csattypes/satellite_types  '
     1                ,j,it,csattypes(jj),' ',satellite_types(it,js)
                endif ! type match
              enddo ! it
            enddo ! j
          endif ! id match
        enddo ! is
      enddo ! i

c ----
c goes08 (first satellite type)

      write(6,*)
      write(6,*)' Determine satellite channels:'
      write(6,*)' nchannel = ',nchannel
      do i=1,ncdim*ntdim*nsdim
          call s_len(cchanneltypes(i),lenc)
          if(lenc .gt. 0)then
              write(6,*)' i,cchanneltypes(i) ',i,trim(cchanneltypes(i))
          endif
      enddo ! i

!     Determine satellite channels without help of 'satdata_lvd_table' at first,
!     though 'satdata_lvd_table' is partially tested near the end of this block
      ICHANNELS = 0
      jj=0
      kk=0
      do i=1,nsats
       write(6,*)' Checking channels for ',i,csatid(i)
       if(csatid(i).eq.'goes08')then
        do j=1,ntypes(i)
         jj=jj+1
c format type 1 (gvr)
         if(csattypes(jj).eq.'gvr')then
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,1,1)=1
            c_channel_types(1,1,1)=cchanneltypes(kk)
            i_msng_sat_flag(1,1,1)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'4u')then
            ICHANNELS(2,1,1)=1
            c_channel_types(2,1,1)=cchanneltypes(kk)
            i_msng_sat_flag(2,1,1)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'wv')then
            ICHANNELS(3,1,1)=1
            c_channel_types(3,1,1)=cchanneltypes(kk)
            i_msng_sat_flag(3,1,1)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'11u')then
            ICHANNELS(4,1,1)=1
            c_channel_types(4,1,1)=cchanneltypes(kk)
            i_msng_sat_flag(4,1,1)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'12u')then
            ICHANNELS(5,1,1)=1
            c_channel_types(5,1,1)=cchanneltypes(kk)
            i_msng_sat_flag(5,1,1)=i_qc_sat_flag(kk)
           endif
          enddo
          path_to_raw_sat(1:6,1,1)=cpath2sat(jj)

c format type 2 (wfo)
!        Note that path_to_raw_sat is specified since wfo is the only
!        satellite with subdirectories for each channel
         elseif(csattypes(jj).eq.'wfo')then
          call s_len(cpath2sat(jj),n)
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,2,1)=1
            c_channel_types(1,2,1)=cchanneltypes(kk)
            path_to_raw_sat(1,2,1)=
!    1        cpath2sat(jj)(1:n)//'conus_vis/regClip/' ! less general
     1        cpath2sat(jj)(1:n)//'conus_'//cchanneltypes(kk)
     1                          //'/regClip/'
            i_msng_sat_flag(1,2,1)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'i39')then
            ICHANNELS(2,2,1)=1
            c_channel_types(2,2,1)=cchanneltypes(kk)
            path_to_raw_sat(2,2,1)=
     1        cpath2sat(jj)(1:n)//'conus_i39/regClip/'
            i_msng_sat_flag(2,2,1)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'iwv')then
            ICHANNELS(3,2,1)=1
            c_channel_types(3,2,1)=cchanneltypes(kk)
            path_to_raw_sat(3,2,1)=
     1        cpath2sat(jj)(1:n)//'conus_iwv/regClip/'
            i_msng_sat_flag(3,2,1)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'i11')then
            ICHANNELS(4,2,1)=1
            c_channel_types(4,2,1)=cchanneltypes(kk)
            path_to_raw_sat(4,2,1)=
     1        cpath2sat(jj)(1:n)//'conus_i11/regClip/'
            i_msng_sat_flag(4,2,1)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'i12')then
            ICHANNELS(5,2,1)=1
            c_channel_types(5,2,1)=cchanneltypes(kk)
            path_to_raw_sat(5,2,1)=
     1        cpath2sat(jj)(1:n)//'conus_i12/regClip/'
            i_msng_sat_flag(5,2,1)=i_qc_sat_flag(kk)
           endif
          enddo

c format type 3 (netcdf)
         elseif(csattypes(jj).eq.'cdf')then
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,3,1)=1
            c_channel_types(1,3,1)=cchanneltypes(kk)
            i_msng_sat_flag(1,3,1)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'i39')then
            ICHANNELS(2,3,1)=1
            c_channel_types(2,3,1)=cchanneltypes(kk)
            i_msng_sat_flag(2,3,1)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'iwv')then
            ICHANNELS(3,3,1)=1
            c_channel_types(3,3,1)=cchanneltypes(kk)
            i_msng_sat_flag(3,3,1)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'i11')then
            ICHANNELS(4,3,1)=1
            c_channel_types(4,3,1)=cchanneltypes(kk)
            i_msng_sat_flag(4,3,1)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'i12')then
            ICHANNELS(5,3,1)=1
            c_channel_types(5,3,1)=cchanneltypes(kk)
            i_msng_sat_flag(5,3,1)=i_qc_sat_flag(kk)
           endif
          enddo
          path_to_raw_sat(1:6,3,1)=cpath2sat(jj)

c format type 4 (raw lat lon)
         elseif(csattypes(jj).eq.'rll')then
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,4,1)=1
            c_channel_types(1,4,1)=cchanneltypes(kk)
            i_msng_sat_flag(1,4,1)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'4u')then
            ICHANNELS(2,4,1)=1
            c_channel_types(2,4,1)=cchanneltypes(kk)
            i_msng_sat_flag(2,4,1)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'wv')then
            ICHANNELS(3,4,1)=1
            c_channel_types(3,4,1)=cchanneltypes(kk)
            i_msng_sat_flag(3,4,1)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'10p')then
            ICHANNELS(4,4,1)=1
            c_channel_types(4,4,1)=cchanneltypes(kk)
            i_msng_sat_flag(4,4,1)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'12u')then
            ICHANNELS(5,4,1)=1
            c_channel_types(5,4,1)=cchanneltypes(kk)
            i_msng_sat_flag(5,4,1)=i_qc_sat_flag(kk)
           endif
          enddo
          path_to_raw_sat(1:6,4,1)=cpath2sat(jj)
         endif
        enddo !type for this sat -> end of types for goes08

       elseif(csatid(i).eq.'meteos_null')then
c
c meteos    #goes09 --- 5-12-99 J. Smart changed to AFWA METEOSAT

        do j=1,ntypes(i)
         jj=jj+1
c format type 3 (raw lat lon)
         if(csattypes(jj).eq.'cdf')then
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,3,2)=1
            c_channel_types(1,3,2)=cchanneltypes(kk)
            i_msng_sat_flag(1,3,2)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'4u')then
            ICHANNELS(2,3,2)=1
            c_channel_types(2,3,2)=cchanneltypes(kk)
            i_msng_sat_flag(2,3,2)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'wv')then
            ICHANNELS(3,3,2)=1
            c_channel_types(3,3,2)=cchanneltypes(kk)
            i_msng_sat_flag(3,3,2)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'11u')then
            ICHANNELS(4,3,2)=1
            c_channel_types(4,3,2)=cchanneltypes(kk)
            i_msng_sat_flag(4,3,2)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'12u')then
            ICHANNELS(5,3,2)=1
            c_channel_types(5,3,2)=cchanneltypes(kk)
            i_msng_sat_flag(5,3,2)=i_qc_sat_flag(kk)
           endif
          enddo
          path_to_raw_sat(1:6,4,2)=cpath2sat(jj)
c format type 4 (raw lat lon)
         elseif(csattypes(jj).eq.'rll')then
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,4,2)=1
            c_channel_types(1,4,2)=cchanneltypes(kk)
            i_msng_sat_flag(1,4,2)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'4u')then
            ICHANNELS(2,4,2)=1
            c_channel_types(2,4,2)=cchanneltypes(kk)
            i_msng_sat_flag(1,4,2)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'wv')then
            ICHANNELS(3,4,2)=1
            c_channel_types(3,4,2)=cchanneltypes(kk)
           elseif(cchanneltypes(kk).eq.'10p')then
            ICHANNELS(4,4,2)=1
            c_channel_types(4,4,2)=cchanneltypes(kk)
           elseif(cchanneltypes(kk).eq.'12u')then
            ICHANNELS(5,4,2)=1
            c_channel_types(5,4,2)=cchanneltypes(kk)
           endif
          enddo
         endif
        enddo
c end of types for meteos
c
c goes10 (third satellite type)
       elseif(csatid(i).eq.'goes10')then
c format type 1 (gvr)
        do j=1,ntypes(i)
         jj=jj+1
         if(csattypes(jj).eq. 'gvr')then
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,1,3)=1
            c_channel_types(1,1,3)=cchanneltypes(kk)
            i_msng_sat_flag(1,1,3)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'4u')then
            ICHANNELS(2,1,3)=1
            c_channel_types(2,1,3)=cchanneltypes(kk)
            i_msng_sat_flag(2,1,3)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'wv')then
            ICHANNELS(3,1,3)=1
            c_channel_types(3,1,3)=cchanneltypes(kk)
            i_msng_sat_flag(3,1,3)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'11u')then
            ICHANNELS(4,1,3)=1
            c_channel_types(4,1,3)=cchanneltypes(kk)
            i_msng_sat_flag(4,1,3)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'12u')then
            ICHANNELS(5,1,3)=1
            c_channel_types(5,1,3)=cchanneltypes(kk)
            i_msng_sat_flag(5,1,3)=i_qc_sat_flag(kk)
           endif
          enddo
          path_to_raw_sat(1:6,1,3)=cpath2sat(jj)
c
c     format type 2 (wfo)
         elseif(csattypes(jj).eq. 'wfo')then
          call s_len(cpath2sat,n)
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,2,3)=1
            c_channel_types(1,2,3)=cchanneltypes(kk)
            path_to_raw_sat(1,2,3)=
     1        cpath2sat(jj)(1:n)//'conus_vis/regClip/'
            i_msng_sat_flag(1,2,3)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'i39')then
            ICHANNELS(2,2,3)=1
            c_channel_types(2,2,3)=cchanneltypes(kk)
            path_to_raw_sat(2,2,3)=
     1        cpath2sat(jj)(1:n)//'conus_i39/regClip/'
            i_msng_sat_flag(2,2,3)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'iwv')then
            ICHANNELS(3,2,3)=1
            c_channel_types(3,2,3)=cchanneltypes(kk)
            path_to_raw_sat(3,2,3)=
     1        cpath2sat(jj)(1:n)//'conus_iwv/regClip/'
            i_msng_sat_flag(3,2,3)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'i11')then
            ICHANNELS(4,2,3)=1
            c_channel_types(4,2,3)=cchanneltypes(kk)
            path_to_raw_sat(4,2,3)=
     1        cpath2sat(jj)(1:n)//'conus_i11/regClip/'
            i_msng_sat_flag(4,2,3)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'i12')then
            ICHANNELS(5,2,3)=1
            c_channel_types(5,2,3)=cchanneltypes(kk)
            path_to_raw_sat(5,2,3)=
     1        cpath2sat(jj)(1:n)//'conus_i12/regClip/'
            i_msng_sat_flag(5,2,3)=i_qc_sat_flag(kk)
           endif
          enddo

c     format type 4 (raw lat lon)
         elseif(csattypes(jj).eq. 'rll')then
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,4,3)=1
            c_channel_types(1,4,3)=cchanneltypes(kk)
            i_msng_sat_flag(1,4,3)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'4u')then
            ICHANNELS(2,4,3)=1
            c_channel_types(2,4,3)=cchanneltypes(kk)
            i_msng_sat_flag(2,4,3)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'wv')then
            ICHANNELS(3,4,3)=1
            c_channel_types(3,4,3)=cchanneltypes(kk)
            i_msng_sat_flag(3,4,3)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'10p')then
            ICHANNELS(4,4,3)=1
            c_channel_types(4,4,3)=cchanneltypes(kk)
            i_msng_sat_flag(4,4,3)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'12u')then
            ICHANNELS(5,4,3)=1
            c_channel_types(5,4,3)=cchanneltypes(kk)
            i_msng_sat_flag(5,4,3)=i_qc_sat_flag(kk)
           endif
          enddo
          path_to_raw_sat(1:6,4,3)=cpath2sat(jj)

         endif  ! switch for types for goes10

        enddo   ! all types for goes10
c gmssat (fourth satellite type)
       elseif(csatid(i).eq.'gmssat')then
        do j=1,ntypes(i)
c     format type 4 (rll)
         jj=jj+1
         if(csattypes(jj).eq.'rll')then
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,4,4)=1
            c_channel_types(1,4,4)=cchanneltypes(kk)
            i_msng_sat_flag(1,4,4)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'wvp')then
            ICHANNELS(3,4,4)=1
            c_channel_types(3,4,4)=cchanneltypes(kk)
            i_msng_sat_flag(3,4,4)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'10p')then
            ICHANNELS(4,4,4)=1
            c_channel_types(4,4,4)=cchanneltypes(kk)
            i_msng_sat_flag(4,4,4)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'12u')then
            ICHANNELS(5,4,4)=1
            c_channel_types(5,4,4)=cchanneltypes(kk)
            i_msng_sat_flag(5,4,4)=i_qc_sat_flag(kk)
           endif
          enddo
          path_to_raw_sat(1:6,4,4)=cpath2sat(jj)

         elseif(csattypes(jj).eq.'hko')then

c     format type 2 (hko):  for HKO (JS  and PW Li 3-20-03)
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,2,4)=1
            c_channel_types(1,2,4)=cchanneltypes(kk)
            i_msng_sat_flag(1,2,4)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'wv ')then
            ICHANNELS(3,2,4)=1
            c_channel_types(3,2,4)=cchanneltypes(kk)
            i_msng_sat_flag(3,2,4)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'ir1')then
            ICHANNELS(4,2,4)=1
            c_channel_types(4,2,4)=cchanneltypes(kk)
            i_msng_sat_flag(4,2,4)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'12u')then
            ICHANNELS(5,2,4)=1
            c_channel_types(5,2,4)=cchanneltypes(kk)
            i_msng_sat_flag(5,2,4)=i_qc_sat_flag(kk)
           endif
          enddo
          path_to_raw_sat(1:6,2,4)=cpath2sat(jj)

         elseif(csattypes(jj).eq.'twn')then

c     format type 3 (twn):  for taiwan (JS  and BS Wang 6-7-01)
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,3,4)=1
            c_channel_types(1,3,4)=cchanneltypes(kk)
            i_msng_sat_flag(1,3,4)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'wv ')then
            ICHANNELS(3,3,4)=1
            c_channel_types(3,3,4)=cchanneltypes(kk)
            i_msng_sat_flag(3,3,4)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'11u')then
            ICHANNELS(4,3,4)=1  !ir1
            c_channel_types(4,3,4)=cchanneltypes(kk)
            i_msng_sat_flag(4,3,4)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'12u')then
            ICHANNELS(5,3,4)=1  !<-- end 4th type
            c_channel_types(5,3,4)=cchanneltypes(kk)
            i_msng_sat_flag(5,3,4)=i_qc_sat_flag(kk)
           endif
          enddo
          path_to_raw_sat(1:6,3,4)=cpath2sat(jj)
         endif
        enddo  !all types for gmssat

c goes12 (fifth satellite type)
       elseif(csatid(i).eq.'goes12')then
        do j=1,ntypes(i)
         jj=jj+1
c format type 1 (gvr)
         if(csattypes(jj).eq.'gvr')then
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,1,5)=1
            c_channel_types(1,1,5)=cchanneltypes(kk)
            i_msng_sat_flag(1,1,5)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'4u')then
            ICHANNELS(2,1,5)=1
            c_channel_types(2,1,5)=cchanneltypes(kk)
            i_msng_sat_flag(2,1,5)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'wv')then
            ICHANNELS(3,1,5)=1
            c_channel_types(3,1,5)=cchanneltypes(kk)
            i_msng_sat_flag(3,1,5)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'11u')then
            ICHANNELS(4,1,5)=1
            c_channel_types(4,1,5)=cchanneltypes(kk)
            i_msng_sat_flag(4,1,5)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'13u')then
            ICHANNELS(6,1,5)=1
            c_channel_types(6,1,5)=cchanneltypes(kk)
            i_msng_sat_flag(6,1,5)=i_qc_sat_flag(kk)
c      C_CHANNEL_TYPES(5,1,5)='   '  !doesn't appear to be 12u for goes12
           endif
          enddo
          path_to_raw_sat(1:6,1,5)=cpath2sat(jj)

         elseif(csattypes(jj).eq.'wfo')then
          call s_len(cpath2sat(jj),n)
c format type 2 (wfo)
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,2,5)=1
            c_channel_types(1,2,5)=cchanneltypes(kk)
            path_to_raw_sat(1,2,5)=
     1        cpath2sat(jj)(1:n)//'conus_vis/regClip/'
            i_msng_sat_flag(1,2,5)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'i39')then
            ICHANNELS(2,2,5)=1
            c_channel_types(2,2,5)=cchanneltypes(kk)
            path_to_raw_sat(2,2,5)=
     1        cpath2sat(jj)(1:n)//'conus_i39/regClip/'
            i_msng_sat_flag(2,2,5)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'iwv')then
            ICHANNELS(3,2,5)=1
            c_channel_types(3,2,5)=cchanneltypes(kk)
            path_to_raw_sat(3,2,5)=
     1        cpath2sat(jj)(1:n)//'conus_iwv/regClip/'
            i_msng_sat_flag(3,2,5)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'i11')then
            ICHANNELS(4,2,5)=1
            c_channel_types(4,2,5)=cchanneltypes(kk)
            path_to_raw_sat(4,2,5)=
     1        cpath2sat(jj)(1:n)//'conus_i11/regClip/'
            i_msng_sat_flag(4,2,5)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'i12')then
            ICHANNELS(5,2,5)=1
            c_channel_types(5,2,5)=cchanneltypes(kk)
            path_to_raw_sat(5,2,5)=
     1        cpath2sat(jj)(1:n)//'conus_i12/regClip/'
            i_msng_sat_flag(5,2,5)=i_qc_sat_flag(kk)
           endif
          enddo

         elseif(csattypes(jj).eq.'cdf')then
c format type 3 (cdf)
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,3,5)=1
            c_channel_types(1,3,5)=cchanneltypes(kk)
            i_msng_sat_flag(1,3,5)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'4u')then
            ICHANNELS(2,3,5)=1
            c_channel_types(2,3,5)=cchanneltypes(kk)
            i_msng_sat_flag(2,3,5)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'wv')then
            ICHANNELS(3,3,5)=1
            c_channel_types(3,3,5)=cchanneltypes(kk)
            i_msng_sat_flag(3,3,5)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'11u')then
            ICHANNELS(4,3,5)=1
            c_channel_types(4,3,5)=cchanneltypes(kk)
            i_msng_sat_flag(4,3,5)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'12u')then
            ICHANNELS(5,3,5)=1
            c_channel_types(5,3,5)=cchanneltypes(kk)
            i_msng_sat_flag(5,3,5)=i_qc_sat_flag(kk)
           endif
          enddo
          path_to_raw_sat(1:6,3,5)=cpath2sat(jj)

         elseif(csattypes(jj).eq.'rll')then
c format type 3 (raw lat lon)
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,4,5)=1
            c_channel_types(1,4,5)=cchanneltypes(kk)
            i_msng_sat_flag(1,4,5)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'4u')then
            ICHANNELS(2,4,5)=1
            c_channel_types(2,4,5)=cchanneltypes(kk)
            i_msng_sat_flag(2,4,5)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'wv')then
            ICHANNELS(3,4,5)=1
            c_channel_types(3,4,5)=cchanneltypes(kk)
            i_msng_sat_flag(3,4,5)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'10p')then
            ICHANNELS(4,4,5)=1
            c_channel_types(4,4,5)=cchanneltypes(kk)
            i_msng_sat_flag(4,4,5)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'12u')then
            ICHANNELS(5,4,5)=1
            c_channel_types(5,4,5)=cchanneltypes(kk)
            i_msng_sat_flag(5,4,5)=i_qc_sat_flag(kk)
           endif
          enddo
          path_to_raw_sat(1:6,4,5)=cpath2sat(jj)
         endif
        enddo

       elseif(csatid(i).eq.'goes09')then
c goes09 (sixth satellite type)
        do j=1,ntypes(i)
         jj=jj+1
c format type 1 (gvr)
         if(csattypes(jj).eq.'gvr')then
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,1,6)=1
            c_channel_types(1,1,6)=cchanneltypes(kk)
            i_msng_sat_flag(1,1,6)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'4u')then
            ICHANNELS(2,1,6)=1
            c_channel_types(2,1,6)=cchanneltypes(kk)
            i_msng_sat_flag(2,1,6)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'wv')then
            ICHANNELS(3,1,6)=1
            c_channel_types(3,1,6)=cchanneltypes(kk)
            i_msng_sat_flag(3,1,6)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'11u')then
            ICHANNELS(4,1,6)=1
            c_channel_types(4,1,6)=cchanneltypes(kk)
            i_msng_sat_flag(4,1,6)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'12u')then
            ICHANNELS(5,1,6)=1
            c_channel_types(5,1,6)=cchanneltypes(kk)
            i_msng_sat_flag(5,1,6)=i_qc_sat_flag(kk)
           endif
          enddo
          path_to_raw_sat(1:6,1,6)=cpath2sat(jj)

         elseif(csattypes(jj).eq.'cdf')then
c format type 3 (cdf)
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,3,6)=1
            c_channel_types(1,3,6)=cchanneltypes(kk)
            i_msng_sat_flag(1,3,6)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'4u')then
            ICHANNELS(2,3,6)=1
            c_channel_types(2,3,6)=cchanneltypes(kk)
            i_msng_sat_flag(2,3,6)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'wv')then
            ICHANNELS(3,3,6)=1
            c_channel_types(3,3,6)=cchanneltypes(kk)
            i_msng_sat_flag(3,3,6)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'11u')then
            ICHANNELS(4,3,6)=1
            c_channel_types(4,3,6)=cchanneltypes(kk)
            i_msng_sat_flag(4,3,6)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'12u')then
            ICHANNELS(5,3,6)=1
            c_channel_types(5,3,6)=cchanneltypes(kk)
            i_msng_sat_flag(5,3,6)=i_qc_sat_flag(kk)
           endif
          enddo
          path_to_raw_sat(1:6,3,6)=cpath2sat(jj)

         elseif(csattypes(jj).eq.'rll')then
c format type 4 (rll)
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,4,6)=1
            c_channel_types(1,4,6)=cchanneltypes(kk)
            i_msng_sat_flag(1,4,6)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'4u')then
            ICHANNELS(2,4,6)=1
            c_channel_types(2,4,6)=cchanneltypes(kk)
            i_msng_sat_flag(2,4,6)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'wv')then
            ICHANNELS(3,4,6)=1
            c_channel_types(3,4,6)=cchanneltypes(kk)
            i_msng_sat_flag(3,4,6)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'10p')then
            ICHANNELS(4,4,6)=1
            c_channel_types(4,4,6)=cchanneltypes(kk)
            i_msng_sat_flag(4,4,6)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'12u')then
            ICHANNELS(5,4,6)=1
            c_channel_types(5,4,6)=cchanneltypes(kk)
            i_msng_sat_flag(5,4,6)=i_qc_sat_flag(kk)
           endif
          enddo
          path_to_raw_sat(1:6,4,6)=cpath2sat(jj)

         endif
        enddo

c satellite = goes11
       elseif(csatid(i).eq.'goes11')then
        do j=1,ntypes(i)
         jj=jj+1
c format type 1 (gvr)
         if(csattypes(jj).eq.'gvr')then
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,1,7)=1
            c_channel_types(1,1,7)=cchanneltypes(kk)
            i_msng_sat_flag(1,1,7)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'4u')then
            ICHANNELS(2,1,7)=1
            c_channel_types(2,1,7)=cchanneltypes(kk)
            i_msng_sat_flag(2,1,7)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'wv')then
            ICHANNELS(3,1,7)=1
            c_channel_types(3,1,7)=cchanneltypes(kk)
            i_msng_sat_flag(3,1,7)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'11u')then
            ICHANNELS(4,1,7)=1
            c_channel_types(4,1,7)=cchanneltypes(kk)
            i_msng_sat_flag(4,1,7)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'13u')then
            ICHANNELS(6,1,7)=1
            c_channel_types(6,1,7)=cchanneltypes(kk)
            i_msng_sat_flag(6,1,7)=i_qc_sat_flag(kk)
c      C_CHANNEL_TYPES(5,1,7)='   '  !doesn't appear to be 12u for goes11 -> ? maybe there is?
           endif
          enddo
          path_to_raw_sat(1:6,1,7)=cpath2sat(jj)

         elseif(csattypes(jj).eq.'wfo')then
          call s_len(cpath2sat(jj),n)
c format type 2 (wfo)
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,2,7)=1
            c_channel_types(1,2,7)=cchanneltypes(kk)
            path_to_raw_sat(1,2,7)=
     1        cpath2sat(jj)(1:n)//'conus_vis/regClip/'
            i_msng_sat_flag(1,2,7)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'i39')then
            ICHANNELS(2,2,7)=1
            c_channel_types(2,2,7)=cchanneltypes(kk)
            path_to_raw_sat(2,2,7)=
     1        cpath2sat(jj)(1:n)//'conus_i39/regClip/'
            i_msng_sat_flag(2,2,7)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'iwv')then
            ICHANNELS(3,2,7)=1
            c_channel_types(3,2,7)=cchanneltypes(kk)
            path_to_raw_sat(3,2,7)=
     1        cpath2sat(jj)(1:n)//'conus_iwv/regClip/'
            i_msng_sat_flag(3,2,7)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'i11')then
            ICHANNELS(4,2,7)=1
            c_channel_types(4,2,7)=cchanneltypes(kk)
            path_to_raw_sat(4,2,7)=
     1        cpath2sat(jj)(1:n)//'conus_i11/regClip/'
            i_msng_sat_flag(4,2,7)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'i12')then
            ICHANNELS(5,2,7)=1
            c_channel_types(5,2,7)=cchanneltypes(kk)
            path_to_raw_sat(5,2,7)=
     1        cpath2sat(jj)(1:n)//'conus_i12/regClip/'
            i_msng_sat_flag(5,2,7)=i_qc_sat_flag(kk)
           endif
          enddo

         elseif(csattypes(jj).eq.'cdf')then
c format type 3 (cdf)
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,3,7)=1
            c_channel_types(1,3,7)=cchanneltypes(kk)
            i_msng_sat_flag(1,3,7)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'4u')then
            ICHANNELS(2,3,7)=1
            c_channel_types(2,3,7)=cchanneltypes(kk)
            i_msng_sat_flag(2,3,7)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'wv')then
            ICHANNELS(3,3,7)=1
            c_channel_types(3,3,7)=cchanneltypes(kk)
            i_msng_sat_flag(3,3,7)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'11u')then
            ICHANNELS(4,3,7)=1
            c_channel_types(4,3,7)=cchanneltypes(kk)
            i_msng_sat_flag(4,3,7)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'12u')then
            ICHANNELS(5,3,7)=1
            c_channel_types(5,3,7)=cchanneltypes(kk)
            i_msng_sat_flag(5,3,7)=i_qc_sat_flag(kk)
           endif
          enddo
          path_to_raw_sat(1:6,3,7)=cpath2sat(jj)

         elseif(csattypes(jj).eq.'rll')then
c format type 4 (raw lat lon)
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,4,7)=1
            c_channel_types(1,4,7)=cchanneltypes(kk)
            i_msng_sat_flag(1,4,7)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'4u')then
            ICHANNELS(2,4,7)=1
            c_channel_types(2,4,7)=cchanneltypes(kk)
            i_msng_sat_flag(2,4,7)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'wv')then
            ICHANNELS(3,4,7)=1
            c_channel_types(3,4,7)=cchanneltypes(kk)
            i_msng_sat_flag(3,4,7)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'10p')then
            ICHANNELS(4,4,7)=1
            c_channel_types(4,4,7)=cchanneltypes(kk)
            i_msng_sat_flag(4,4,7)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'12u')then
            ICHANNELS(5,4,7)=1
            c_channel_types(5,4,7)=cchanneltypes(kk)
            i_msng_sat_flag(5,4,7)=i_qc_sat_flag(kk)
           endif
          enddo
          path_to_raw_sat(1:6,4,7)=cpath2sat(jj)

         endif
        enddo

c satellite = NOAA POLAR ORBITER NETCDF
       elseif(csatid(i).eq.'noaapo')then
        do j=1,ntypes(i)
         jj=jj+1
c format type 1 (ncp): netcdf polar (FMI's data type). Stored like wfo
         if(csattypes(jj).eq.'ncp')then
          call s_len(cpath2sat(jj),n)
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,1,8)=1
            c_channel_types(1,1,8)=cchanneltypes(kk)
            path_to_raw_sat(1,1,8)=cpath2sat(kk)(1:n)//'/vis/'
            i_msng_sat_flag(1,1,8)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'i39')then
            ICHANNELS(2,1,8)=1
            c_channel_types(2,1,8)=cchanneltypes(kk)
            path_to_raw_sat(2,1,8)=cpath2sat(kk)(1:n)//'/i39/'
            i_msng_sat_flag(2,1,8)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'i11')then
            ICHANNELS(4,1,8)=1
            c_channel_types(4,1,8)=cchanneltypes(kk)
            path_to_raw_sat(4,1,8)=cpath2sat(kk)(1:n)//'/i11/'
            i_msng_sat_flag(4,1,8)=i_qc_sat_flag(kk)
           endif
          enddo

         elseif(csattypes(jj).eq.'rll')then
c format type 4 (rll)
          do k=1,nchannel(jj)
           kk=kk+1
           if(cchanneltypes(kk).eq.'vis')then
            ICHANNELS(1,4,8)=1
            c_channel_types(1,4,8)=cchanneltypes(kk)
            i_msng_sat_flag(1,4,8)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'4u ')then
            ICHANNELS(2,4,8)=1
            c_channel_types(2,4,8)=cchanneltypes(kk)
            i_msng_sat_flag(2,4,8)=i_qc_sat_flag(kk)
           elseif(cchanneltypes(kk).eq.'10p')then
            ICHANNELS(4,4,8)=1
            c_channel_types(4,4,8)=cchanneltypes(kk)
            i_msng_sat_flag(4,4,8)=i_qc_sat_flag(kk)
           endif
          enddo
          path_to_raw_sat(1:6,4,8)=cpath2sat(jj)
         endif
        enddo

       else ! more general formulation for channels

c format type 1 (ncp): netcdf polar (FMI's data type). Stored like wfo
c format type 4 (rll)

        do js = 1,maxsat

         if(js .eq. 2 .OR. js .ge. 9)then

          if(trim(csatid(i)).eq.trim(satellite_ids(js)))then

           do j=1,ntypes(i)

            jj=jj+1

            do it = 1,4

             if(csattypes(jj).eq.satellite_types(it,js))then

              do k=1,nchannel(jj)
                kk=kk+1

                do ic = 1,maxchannel
                    if(cchanneltypes(kk).eq.satellite_channels(it,ic,js)
     1                                                             )then
                        write(6,*)' Test channel match ',it,js,ic
     1                           ,kk,cchanneltypes(kk)
                    endif
                enddo

                ic=0
                if(cchanneltypes(kk).eq.'vis')then
                  ic=1
                elseif(cchanneltypes(kk).eq.'4u ')then
                  ic=2
                elseif(cchanneltypes(kk).eq.'10p')then
                  ic=4
                elseif(cchanneltypes(kk).eq.'11u')then
                  ic=4
                endif

                if(ic .gt. 0)then
                  ICHANNELS(ic,it,js)=1
                  c_channel_types(ic,it,js)=cchanneltypes(kk)
                  i_msng_sat_flag(ic,it,js)=i_qc_sat_flag(kk)
                  write(6,*)' Channel Match js/it/k/kk/ic'
     1                                     ,js,it,k,kk,ic,csatid(i)
     1                                     ,cchanneltypes(kk)
                else
                  write(6,*)' No Channel Match js/it/k/kk/ic'
     1                                     ,js,it,k,kk,ic,csatid(i)
     1                                     ,cchanneltypes(kk)
                endif ! valid ic found

              enddo ! k

              path_to_raw_sat(1:6,it,js)=cpath2sat(jj)

             endif ! match of sat types
            enddo ! it = 1,4
           enddo ! j = 1,ntypes
          endif ! test of csatid (specific test)
         endif ! range of satellite numbers (js) using simplified loop
        enddo ! js
       endif ! test of csatid (9 or greater)
      enddo ! i = 1,nsats
      print*,'Done in conf_isjtkc. Returning to config_satellite_lvd'
      return
      end

max_stars_repo_name: maxinye/laps-mirror

max_stars_repo_licenses: Intel Unlicense OLDAP-2.2.1 NetCDF

max_issues_repo_name: longwosion/laps-mirror

max_issues_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense

max_forks_repo_name: longwosion/laps-mirror

max_forks_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense


    program test_set_value_at_indices

    use bmif_2_0, only: BMI_SUCCESS, BMI_FAILURE
    use bmiprmssurface
    use fixtures, only: config_file, status, print_1darray, isReal4EqualReal4, &
        isReal8EqualReal8, print_i_1darray, print_array, isintEqualint

    implicit none

    type (bmi_prms_surface) :: m
    integer :: retcode

    retcode = test1()
    if (retcode.ne.BMI_SUCCESS) then
        stop BMI_FAILURE
    end if

    retcode = test2()
    if (retcode.ne.BMI_SUCCESS) then
        stop BMI_FAILURE
    end if

    contains

  ! Test getting r32 hru_area.
  function test1() result(code)
    character (len=*), parameter :: &
         var_name = "hru_ppt"
    integer, parameter :: rank = 1
    integer, parameter :: size = 7
    integer, parameter :: fsize = 14

    integer, parameter, dimension(rank) :: shape = (/ 7 /)
    integer, parameter, dimension(rank) :: fshape = (/ 14 /)
    integer, parameter, dimension(size) :: &
       indices = (/ 2, 4, 6, 8, 10, 12, 14 /)
    real, parameter, dimension(size) :: &
         setv = (/0.25,0.25,0.25,0.25,0.25,0.25,0.25/)
    real, parameter, dimension(fsize) :: &
         full_expected = (/0.0, 0.25, 0.0, 0.25, 0.0, 0.25, 0.0, 0.25, 0.0, 0.25, 0.0, 0.25, 0.0, 0.25/)
    real :: tval(size), ftval(fsize)
    integer :: i, code

    status = m%initialize(config_file)
    status = m%update()
    status = m%get_value_at_indices(var_name, tval, indices)
    status = m%set_value_at_indices(var_name, indices, setv)
    if (status .eq. 1) then
        code = 0 ! set_value_at_indices not set for hru_ppt
    else
        code = 1
    endif
  end function test1

  function test2() result(code)
    character (len=*), parameter :: &
         var_name = "dprst_vol_open"

    integer, parameter :: rank = 1
    integer, parameter :: size = 7
    integer, parameter :: fsize = 14
    integer, parameter, dimension(rank) :: shape = (/ 7 /)
    integer, parameter, dimension(rank) :: fshape = (/ 14 /)
    integer, parameter, dimension(size) :: &
       indices = (/ 2, 4, 6, 8, 10, 12, 14 /)
    double precision, parameter :: expected(size) = (/ &
        224.910984328835, 8057.99076883995, 10864.8073074743, &
        253.518300425138, 1121.18710758845, 0.000000000000000, &
        12585.9414342218 /)

    double precision, parameter :: fexpected(fsize) = (/ &
        41558.0385172600, 224.910984328835, 5545.71725420578, 8057.99076883995, &
        3514.98316578602, 10864.8073074743, 3220.60291601327, 253.518300425138, &
        556.593107720004, 1121.18710758845, 88.9853008034370, 0.00000000000000, &
        259.981427881226, 12585.9414342218 /)
    double precision :: setv(size), fsetv(fsize)
    double precision :: val(size), fval(fsize)
    integer :: i, code

    status = m%initialize(config_file)
    status = m%get_value(var_name, fval)
    status = m%get_value_at_indices(var_name, val, indices)
    setv = 1.5*val
    status = m%set_value_at_indices(var_name, indices, setv)
    status = m%get_value_at_indices(var_name, val, indices)
    status = m%get_value(var_name, fval)
    status = m%finalize()

    ! Visual inspection.
    write(*,*) "Test 2"
    write(*,*) "Expected"
    write(*,*) setv
    write(*,*) "set value"
    write(*,*) val

    code = BMI_SUCCESS
    do i = 1, size
       if (isreal8equalreal8(setv(i), val(i)).neqv..TRUE.) then
          code = BMI_FAILURE
       end if
    end do

        ! Visual inspection.
    write(*,*) "Test 2 full value"
    write(*,*) "Expected"
    write(*,*) fexpected
    write(*,*) "set value"
    write(*,*) fval

    !the above is correct but test below doesn't work, there are some precision issues I
    !don't understand...

    !code = BMI_SUCCESS
    !do i = 1, size
    !   if (isreal8equalreal8(fexpected(i), fval(i)).ne..TRUE.) then
    !      code = BMI_FAILURE
    !   end if
    !end do
  end function test2

    end program test_set_value_at_indices


text:
C Copyright(C) 2011 Sandia Corporation.  Under the terms of Contract
C DE-AC04-94AL85000 with Sandia Corporation, the U.S. Government retains
C 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=======================================================================
      SUBROUTINE DBINM1 (NDB, TYPE, OPTION, NBLK, NVAR, ISEVOK, IEVOK,
     &                   ITMP, IERR, NBDM, *)
C=======================================================================
C   --*** DBINM1 *** (EXOLIB) Internal to DBINAM
C   --   Written by Amy Gilkey - revised 02/18/88
C   --
C   --DBINM1 reads the element block variable truth table.
C   --
C   --Parameters:
C   --   NDB    - IN  - the database number
C   --   OPTION - IN  - ' ' to not store, '*' to store all, else store options:
C   --                  'T' to store element block variable truth table
C   --   NELBLK - IN  - the number of element blocks
C   --   NVAREL - IN  - the number of element variables
C   --   ISEVOK - OUT - the element block variable truth table;
C   --                  variable i of block j exists iff ISEVOK(j,i)
C   --   IEVOK  - OUT - the element block variable truth table;
C   --                  variable i of block j exists iff ISEVOK(j,i) is NOT 0
C   --   IERR   - OUT - the returned read error flag
C   --   *      - OUT - return statement if error encountered
C   --                  NO message is printed
C   --
C   --Database must be positioned in front of truth table upon entry;
C   --upon exit positioned after table.

      include 'exodusII.inc'
      INTEGER NDB
      CHARACTER*1 TYPE
      CHARACTER*(*) OPTION
      INTEGER NBLK, NVAR
      LOGICAL ISEVOK(NBDM,*)
      INTEGER IEVOK(NBDM,*)
      INTEGER ITMP(NVAR,NBDM)
      INTEGER IERR

      if (nvar .le. 0) return
      IF ((OPTION .EQ. '*') .OR. (INDEX (OPTION, 'T') .GT. 0)) THEN
         if (type .eq. 'E') then
            call exgvtt (ndb, nblk, nvar, itmp, ierr)
         else if (type .eq. 'M') then
            call exgnstt (ndb, nblk, nvar, itmp, ierr)
         else if (type .eq. 'S') then
            call exgsstt (ndb, nblk, nvar, itmp, ierr)
         end if
         IF (ierr .eq. 17) then
            DO 20 I = 1, NVAR
               DO 10 IELB = 1, NBLK
                  ISEVOK(IELB,I) = .true.
 10            CONTINUE
 20         CONTINUE
         ELSE
            DO 110 I = 1, NVAR
               DO 100 IELB = 1, NBLK
                  ISEVOK(IELB,I) = (ITMP(I,IELB) .NE. 0)
 100           CONTINUE
 110        CONTINUE
         ENDIF

      END IF

      RETURN

      END

max_stars_repo_name: milljm/seacas

max_issues_repo_name: milljm/seacas

max_forks_repo_name: milljm/seacas


text:
!##############################################################################
!# ****************************************************************************
!# <name> structuresnewton </name>
!# ****************************************************************************
!#
!# <purpose>
!# General structures for Newton algorithms -- in space as well as in
!# space-time.
!# </purpose>
!##############################################################################

module structuresnewton

  use fsystem
  use genoutput
  use paramlist
  use linearalgebra
  use iterationcontrol

  implicit none

  private

!<constants>

!<constantblock description="Constants defining the partial Newton">

  ! Full Newton
  integer, parameter, public :: NEWTN_PN_FULLNEWTON = 0

  ! Partial Newton
  integer, parameter, public :: NEWTN_PN_PARTIALNEWTON = 1

  ! Partial Newton in the dual equation, full Newton in the primal equation
  integer, parameter, public :: NEWTN_PN_PARTIALNEWTONDUAL = 2

!</constantblock>

!</constants>

!<type>

  ! This structure controls the Newton iteration -- i.e. the preconditioning
  ! with the Frechet derivative of the Navier--Stokes equation, which
  ! can lead to quadratic covergence of the nonlinear solver.
  ! As Newton works only in the basin of attraction of the solution,
  ! the parameters in this structure allow to define a switching criterion
  ! when to use Newton. In the first couple of iterations, defect correction
  ! is used, while the iteration switches to Newton if the residuum is small
  ! enough.
  ! This block is used if CCPREC_NEWTONDYNAMIC is used as preconditioner.
  type t_ccDynamicNewtonControl

    ! Type of partial Newton to apply.
    ! =0: No partial Newton.
    ! =1: Use partial Newton until nmaxFixedPointIterations is reached.
    !     For primal/dual problems: Use partial Newton in the primal and
    !     dual equation.
    ! =2: For primal/dual problems: Use full Newton in the primal and
    !     partial Newton in the dual equation until nmaxFixedPointIterations
    !     is reached.
    integer :: cpartialNewton = NEWTN_PN_FULLNEWTON

    ! Minimum number of partial Newton iterations before switching to
    ! the full Newton
    integer :: nminPartialNewtonIterations = 0

    ! Maximum number of partial Newton iterations before switching to
    ! the full Newton
    integer :: nmaxPartialNewtonIterations = 0

    ! Norm of absolute residuum before applying the full Newton.
    ! Newton is only applied
    ! if   ||absolute residuum|| < dtolAbsNewton
    ! and  ||relative residuum|| < dtolRelNewton.
    ! Otherwise, the usual fix point iteration is used.
    ! Value = 0.0: Disable check.
    real(DP) :: dtolAbsPartialNewton = 0.0_DP

    ! Norm of relative residuum before applying Newton.
    ! Newton is only applied
    ! if   ||absolute residuum|| < dtolAbsNewton
    ! and  ||relative residuum|| < dtolRelNewton.
    ! Otherwise, the usual fix point iteration is used.
    ! Standard value = 1E-1.
    ! Value = 0.0: Disable check.
    real(DP) :: dtolRelPartialNewton = 1.0E-1_DP

    ! Whether to use the inexact Newton iteration or not.
    ! The inexact Newton controls the stopping criterion of the linear
    ! solver according to the nonlinear residual.
    integer :: cinexactNewton = 1

    ! Stopping criterion for the linear solver in the inexact Newton iteration.
    ! Controls the minimum number of digits to gain in the linear solver
    ! per Newton iteration.
    real(dp) :: dinexactNewtonTolRel = 1.0E-2_DP

    ! Exponent to control the stopping criterion for the linear solver in
    ! an inexact Newton iteration. =2 result in quadratic convergence,
    ! =1.5 in superlinear convergence.
    real(dp) :: dinexactNewtonExponent = 2.0_DP

    ! Lower bound for the absolute residual. Subproblems are not solved
    ! more exact than this.
    real(DP) :: dinexactNewtonTolAbs = 1E-15_DP

    ! Number of smoothing steps after a Newton step.
    integer :: nsmoothingSteps = 0

    ! Step length strategy.
    ! =0: No step length control.
    ! =1: Damp with domega for the first nsteplengthSteps steps, then switch to full Newton.
    integer :: cstepLengthStrategy = 0

    ! Damping parameter
    real(DP) :: dstepLengthOmega = 1.0_DP

    ! Number of steps
    integer :: nstepLengthSteps = 0

  end type

!</typeblock>

  public :: t_ccDynamicNewtonControl

!<typeblock>

  ! Contains the parameters of the Newton iteration.
  type t_newtonParameters

    ! <!-- -------------- -->
    ! <!-- STATUS, OUTPUT -->
    ! <!-- -------------- -->

    ! OUTPUT: Result
    ! The result of the solution process.
    ! =-1: convergence criterion not reached.
    ! =0: success.
    ! =1: iteration broke down, diverging.
    ! =2: iteration broke down, preconditioner did not work.
    ! =3: error in the parameters.
    integer :: iresult = 0

    ! Output level of the solver.
    ! =-1: no output
    ! =0: no output, only errors
    ! =1: basic output
    ! =2: standard output
    integer :: ioutputLevel = 2

    ! Output mode. Used for printing messages.
    ! =OU_MODE_STD: Print messages to the terminal and probably to a log
    ! file (if a log file is opened).
    integer(I32) :: coutputmode = OU_MODE_STD

    ! <!-- ----------------------------------------- -->
    ! <!-- STOPPING CRITERIA, DAMPING PARAMETERS,... -->
    ! <!-- ----------------------------------------- -->

    ! Type of the iteration.
    ! =-1: undefined
    ! =0: simple linear solver
    ! =1: nonlinear loop for a semilinear equation
    ! =2: Newton solver
    ! =3: adaptive Newton with parameters in radaptiveNewton
    integer :: ctypeIteration = -1

    ! Type of stopping criterion to use for standard convergence test. One of the
    ! NLSOL_STOP_xxxx constants.
    ! Note: This parameter is only evaluated in the stanard convergence test.
    ! If the caller of the nonlinear solver specifies a callback routine fcb_resNormCheck
    ! for checking the convergence, that callback routine must implement its own
    ! logic to handle relative and absolute convrgence criteria!
    ! integer :: cstoppingCriterion = NLSOL_STOP_STANDARD

    ! Type of norm to use in the residual checking of the total vector
    ! (cf. linearalgebra.f90).
    ! =0: euclidian norm, =1: l1-norm, =2: l2-norm, =3: MAX-norm
    ! integer :: iresNormTotal = 2

    ! RHS-vector is treated as zero if max(defect) < drhsZero
    real(DP) :: drhsZero = 1E-90_DP

    ! How to check residuals.
    ! =0: Check in Euclidian norm (like in old CC).
    ! =2: L2-norm
    integer :: iresNorm = LINALG_NORML2

    ! Damping parameter for the Newton iteration
    real(DP) :: domega = 1.0_DP

    ! <!-- ----------------------------- -->
    ! <!-- SUBSOLVERS AND OTHER SETTINGS -->
    ! <!-- ----------------------------- -->

    ! Parameters for the dynamic and inexact Newton algorithm
    type(t_ccDynamicNewtonControl) :: radaptiveNewton

  end type

!</typeblock>

  public :: t_newtonParameters

!<typeblock>

  ! Standard parameters for preconditioners in a Newton iteration
  type t_newtonPrecParameters

    ! <!-- -------------- -->
    ! <!-- STATUS, OUTPUT -->
    ! <!-- -------------- -->

    ! OUTPUT: Result
    ! The result of the solution process.
    ! =-1: convergence criterion not reached.
    ! =0: success.
    ! =1: iteration broke down, diverging.
    ! =2: iteration broke down, preconditioner did not work.
    ! =3: error in the parameters.
    integer :: iresult = 0

    ! Output level of the solver.
    ! =-1: no output
    ! =0: no output, only errors
    ! =1: basic output
    ! =2: standard output
    integer :: ioutputLevel = 2

    ! Output mode. Used for printing messages.
    ! =OU_MODE_STD: Print messages to the terminal and probably to a log
    ! file (if a log file is opened).
    integer(I32) :: coutputmode = OU_MODE_STD

    ! How to check residuals.
    ! =0: Check in Euclidian norm (like in old CC).
    ! =2: L2-norm
    integer :: iresNorm = LINALG_NORML2

    ! RHS-vector is treated as zero if max(defect) < drhsZero
    real(DP) :: drhsZero = 1E-90_DP

    ! Damping parameter
    real(DP) :: domega = 1.0_DP

  end type

!</typeblock>

  public :: t_newtonPrecParameters

!</types>

  ! Basic initialisation of the Newton solver
  public :: newtonit_initBasicParams

  ! Basic initialisation of the Newton solver
  public :: newtonlin_initBasicParams

contains

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

!<subroutine>

  subroutine newtonit_initBasicParams (rsolver,riter,ssection,rparamList)

!<description>
  ! Initialises basic solver parameters according to a parameter list.
!</description>

!<input>
  ! Parameter list with the parameters configuring the nonlinear solver
  type(t_parlist), intent(in) :: rparamList

  ! Name of the section in the parameter list containing the parameters
  ! of the nonlinear solver.
  character(LEN=*), intent(in) :: ssection
!</input>

!<output>
  ! Solver structure receiving the parameters
  type(t_newtonParameters), intent(inout) :: rsolver

  ! Structure receiving iteration control parameters
  type(t_iterationControl), intent(inout) :: riter
!</output>

!</subroutine>

    ! local variables
    type(t_parlstSection), pointer :: p_rsection
    character(len=SYS_STRLEN) :: sstring,snewton

    call parlst_querysection(rparamList, ssection, p_rsection)

    if (.not. associated(p_rsection)) then
      call output_line ("Cannot create nonlinear solver; no section """//&
          trim(ssection)//"""!", &
          OU_CLASS_ERROR,OU_MODE_STD,"newtonit_initBasicParams")
      call sys_halt()
    end if

    ! Read iteration control parameters
    call itc_getParamsFromParlist(riter,ssection,rparamList)

    ! Read additional parameters
    call parlst_getvalue_double (p_rsection, "domega", &
                                 rsolver%domega, rsolver%domega)

    call parlst_getvalue_int (p_rsection, "ioutputLevel", &
        rsolver%ioutputLevel, rsolver%ioutputLevel)

    call parlst_getvalue_int (p_rsection, "iresnorm", &
        rsolver%iresnorm, rsolver%iresnorm)

    ! Get information about the iteration.

    ! At first, ask the parameters in the INI/DAT file which type of
    ! preconditioner is to be used. The data in the preconditioner structure
    ! is to be initialised appropriately!
    call parlst_getvalue_int (p_rsection, "ctypeIteration", &
        rsolver%ctypeIteration, rsolver%ctypeIteration)

    ! We have even the extended, dynamic Newton as preconditioner.
    ! Put the parameters for the extended Newton from the DAT file
    ! into the Adaptive-Newton configuration block.

    call parlst_getvalue_string (rparamList, ssection, &
        "ssectionAdaptiveNewton", sstring, "", bdequote=.true.)
    snewton = ""
    if (sstring .ne. "") read (sstring,*) snewton
    if (snewton .ne. "") then
      ! Initialise the parameters of the adaptive Newton
      call parlst_getvalue_int (rparamList, snewton, &
          "cpartialNewton", &
          rsolver%radaptiveNewton%cpartialNewton, &
          rsolver%radaptiveNewton%cpartialNewton)

      call parlst_getvalue_int (rparamList, snewton, &
          "nminPartialNewtonIterations", &
          rsolver%radaptiveNewton%nminPartialNewtonIterations, &
          rsolver%radaptiveNewton%nminPartialNewtonIterations)

      call parlst_getvalue_int (rparamList, snewton, &
          "nmaxPartialNewtonIterations", &
          rsolver%radaptiveNewton%nmaxPartialNewtonIterations, &
          rsolver%radaptiveNewton%nmaxPartialNewtonIterations)

      call parlst_getvalue_double (rparamList, snewton, &
          "dtolAbsPartialNewton", &
          rsolver%radaptiveNewton%dtolAbsPartialNewton, &
          rsolver%radaptiveNewton%dtolAbsPartialNewton)

      call parlst_getvalue_double (rparamList, snewton, &
          "dtolRelPartialNewton", &
          rsolver%radaptiveNewton%dtolRelPartialNewton, &
          rsolver%radaptiveNewton%dtolRelPartialNewton)

      call parlst_getvalue_int (rparamList, snewton, &
          "cinexactNewton", &
          rsolver%radaptiveNewton%cinexactNewton, &
          rsolver%radaptiveNewton%cinexactNewton)

      call parlst_getvalue_double (rparamList, snewton, &
          "dinexactNewtonTolRel", &
          rsolver%radaptiveNewton%dinexactNewtonTolRel, &
          rsolver%radaptiveNewton%dinexactNewtonTolRel)

      call parlst_getvalue_double (rparamList, snewton, &
          "dinexactNewtonExponent", &
          rsolver%radaptiveNewton%dinexactNewtonExponent, &
          rsolver%radaptiveNewton%dinexactNewtonExponent)

      call parlst_getvalue_double (rparamList, snewton, &
          "dinexactNewtonTolAbs", &
          rsolver%radaptiveNewton%dinexactNewtonTolAbs, &
          rsolver%radaptiveNewton%dinexactNewtonTolAbs)

      call parlst_getvalue_int (rparamList, snewton, &
          "nsmoothingSteps", &
          rsolver%radaptiveNewton%nsmoothingSteps, &
          rsolver%radaptiveNewton%nsmoothingSteps)

      call parlst_getvalue_int (rparamList, snewton, &
          "cstepLengthStrategy", &
          rsolver%radaptiveNewton%cstepLengthStrategy, &
          rsolver%radaptiveNewton%cstepLengthStrategy)

      call parlst_getvalue_int (rparamList, snewton, &
          "nstepLengthSteps", &
          rsolver%radaptiveNewton%nstepLengthSteps, &
          rsolver%radaptiveNewton%nstepLengthSteps)

      call parlst_getvalue_double (rparamList, snewton, &
          "dstepLengthOmega", &
          rsolver%radaptiveNewton%dstepLengthOmega, &
          rsolver%radaptiveNewton%dstepLengthOmega)

    end if

  end subroutine

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

!<subroutine>

  subroutine newtonlin_initBasicParams (rsolver,riter,ssection,rparamList)

!<description>
  ! Initialises basic solver parameters according to a parameter list.
!</description>

!<input>
  ! Parameter list with the parameters configuring the nonlinear solver
  type(t_parlist), intent(in) :: rparamList

  ! Name of the section in the parameter list containing the parameters
  ! of the nonlinear solver.
  character(LEN=*), intent(in) :: ssection
!</input>

!<output>
  ! Solver structure receiving the parameters
  type(t_newtonPrecParameters), intent(inout) :: rsolver

  ! Structure receiving iteration control parameters
  type(t_iterationControl), intent(inout) :: riter
!</output>

!</subroutine>

    ! local variables
    type(t_parlstSection), pointer :: p_rsection

    call parlst_querysection(rparamList, ssection, p_rsection)

    if (.not. associated(p_rsection)) then
      call output_line ("Cannot create linear solver; no section """//&
          trim(ssection)//"""!", &
          OU_CLASS_ERROR,OU_MODE_STD,"newtonlin_initBasicParams")
      call sys_halt()
    end if

    ! Read iteration control parameters
    call itc_getParamsFromParlist(riter,ssection,rparamList)

    call parlst_getvalue_int (p_rsection, "ioutputLevel", &
        rsolver%ioutputLevel, rsolver%ioutputLevel)

    call parlst_getvalue_int (p_rsection, "iresnorm", &
        rsolver%iresnorm, rsolver%iresnorm)

    call parlst_getvalue_double (p_rsection, "domega", &
        rsolver%domega, rsolver%domega)

  end subroutine

end module

max_stars_repo_licenses: Intel Unlicense

max_issues_repo_licenses: Intel Unlicense

max_forks_repo_licenses: Intel Unlicense


text:
! { dg-do compile }
! PR42684 (42680) Ice with Interface.
MODULE mod1
  IMPLICIT NONE
  TYPE ta
    INTEGER i
  END TYPE ta
  INTERFACE OPERATOR(+)
    MODULE PROCEDURE add_a
  END INTERFACE OPERATOR(+)
CONTAINS
  FUNCTION add_a(lhs, rhs) RESULT(r)
    TYPE(ta), INTENT(IN) :: lhs
    TYPE(ta), INTENT(IN) :: rhs
    TYPE(ta) :: r
    !****
    r%i = lhs%i + rhs%i
  END FUNCTION add_a
END MODULE mod1

MODULE mod2
  IMPLICIT NONE
  TYPE tb
    INTEGER j
  END TYPE tb
  INTERFACE OPERATOR(+)
    MODULE PROCEDURE add_b
  END INTERFACE OPERATOR(+)
CONTAINS
  SUBROUTINE other_proc()
    USE mod1    ! Causes ICE
  END SUBROUTINE other_proc
  FUNCTION add_b(lhs, rhs) RESULT(r)
    TYPE(tb), INTENT(IN) :: lhs
    TYPE(tb), INTENT(IN) :: rhs
    TYPE(tb) :: r
    !****
    r%j = lhs%j + rhs%j
  END FUNCTION add_b
END MODULE mod2
! { dg-final { cleanup-modules "mod1 mod2" } }

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab