text:
! (c) 2011 University of Houston System.  All rights reserved.

!
! rotate PE id to right neighbor (dest), with wrap-around
!

program rotput

  integer, save :: dest
  integer src
  integer me, npes
  integer nextpe

  include 'mpp/shmem.fh'

  call start_pes(0)
  me = my_pe()
  npes = num_pes()

  nextpe = MOD(me + 1, npes)

  src = nextpe;

  dest = -1;
  call shmem_barrier_all()

  call shmem_integer_put(dest, src, 1, nextpe)

  call shmem_barrier_all()

  if (dest == me) then
     print *, me, ': got ', dest, 'CORRECT'
  else
     print *, me, ': got ', dest, 'WRONG'
  end if

end program rotput

max_stars_repo_name: eugeneswalker/taucmdr

max_issues_repo_name: eugeneswalker/taucmdr

max_forks_repo_name: eugeneswalker/taucmdr


! { dg-do compile }
! { dg-options "-fcoarray=single" }
!
      program cg
        implicit none
        integer reduce_recv_starts(2)[1,0:*]
        interface
          subroutine conj_grad (reduce_recv_starts) ! { dg-warning "Interface mismatch in global procedure 'conj_grad' at \\(1\\): Corank mismatch in argument 'reduce_recv_starts' \\(2/1\\)" }
            integer   reduce_recv_starts(2)[2, 2:*]
          end subroutine
        end interface
        call conj_grad (reduce_recv_starts) ! Corank mismatch is okay
      end

      subroutine conj_grad (reduce_recv_starts)
        implicit none
        integer reduce_recv_starts(2)[2:*]
      end


text:
MODULE vars_model

USE common,       ONLY: r_size

IMPLICIT NONE

PUBLIC

!-----------------------------------------------------------------------------
  REAL(r_size),ALLOCATABLE,DIMENSION(:),SAVE   :: lon !(nlon)
  REAL(r_size),ALLOCATABLE,DIMENSION(:),SAVE   :: lat !(nlat)
  REAL(r_size),ALLOCATABLE,DIMENSION(:),SAVE   :: lev !(nlev)                     !(OCEAN)
  REAL(r_size),ALLOCATABLE,DIMENSION(:,:),SAVE :: lon2d !(nlon,nlat)      !(2DGRID)(For irregular grids)
  REAL(r_size),ALLOCATABLE,DIMENSION(:,:),SAVE :: lat2d !(nlon,nlat)      !(2DGRID)(For irregular grids)
  REAL(r_size),ALLOCATABLE,DIMENSION(:,:),SAVE :: lev2d !(nlon,nlat)      !(2DGRID)(For irregular grids)

  REAL(r_size),ALLOCATABLE,DIMENSION(:,:),SAVE :: dx !(nlon,nlat)
  REAL(r_size),ALLOCATABLE,DIMENSION(:,:),SAVE :: dy !(nlon,nlat)
  REAL(r_size),ALLOCATABLE,DIMENSION(:,:),SAVE :: area_t !(nlon,nlat)
  REAL(r_size),ALLOCATABLE,DIMENSION(:,:),SAVE :: phi0 !(nlon,nlat)
  REAL(r_size),ALLOCATABLE,DIMENSION(:,:),SAVE :: kmt0 !(nlon,nlat)               !(OCEAN)
  REAL(r_size),ALLOCATABLE,DIMENSION(:,:,:),SAVE :: height !(nlon,nlat,nlev)      !(OCEAN)
  REAL(r_size),ALLOCATABLE,DIMENSION(:,:),SAVE :: wet !(nlon,nlat)

  REAL(r_size),ALLOCATABLE,DIMENSION(:),SAVE     :: fcori   !(nlat)
  REAL(r_size),ALLOCATABLE,DIMENSION(:,:),SAVE   :: fcori2d !(nlon,nlat)
  INTEGER,ALLOCATABLE,DIMENSION(:,:),SAVE        :: kmt     !(OCEAN) STEVE: the bottom topography for mom4
  INTEGER,ALLOCATABLE,DIMENSION(:,:),SAVE        :: pmsk    ! JILI HYCOM mask
  INTEGER,ALLOCATABLE,DIMENSION(:,:),SAVE        :: umsk
  INTEGER,ALLOCATABLE,DIMENSION(:,:),SAVE        :: vmsk
  REAL(r_size),ALLOCATABLE,DIMENSION(:,:),SAVE   :: SSHclm_m  !(OCEAN)(SLA) Stores model climatology to subtract from model eta_t when assimilating SLA
  ! For AMOC computation
  REAL(r_size),ALLOCATABLE,DIMENSION(:),SAVE :: zb !(nlev)
  REAL(r_size),ALLOCATABLE,DIMENSION(:),SAVE :: dz !(nlev)
!-----------------------------------------------------------------------------

  ! For reading in NCODA z-levels:
  REAL(r_size), DIMENSION(100) :: z_lvl  ! STEVE: only use the first nlev levels

  !STEVE: For generalized grid
  REAL(r_size),SAVE :: lon0, lonf, lat0, latf
  REAL(r_size),SAVE :: wrapgap

  LOGICAL,SAVE :: vars_model_initialized = .false.
  LOGICAL,SAVE :: vars_model_set         = .false.

CONTAINS
!-----------------------------------------------------------------------------
!-----------------------------------------------------------------------------
!-----------------------------------------------------------------------------

SUBROUTINE initialize_vars_model

  !-----------------------------------------------------------------------------
  ! Initialize the model variables
  !-----------------------------------------------------------------------------
  USE common, ONLY: r_size
  USE params_model, ONLY: nlon, nlat, nlev, params_model_initialized

  IMPLICIT NONE

  if (.not. params_model_initialized) then
    WRITE(6,*) "vars_model.f90::initialize_vars_model::"
    WRITE(6,*) "ERROR: must call initialize_params_model before calling initialize_vars_model. EXITING..."
    STOP(85)
  elseif (vars_model_initialized) then
    WRITE(6,*) "initialize_vars_model:: already initialized, RETURNING..."
    RETURN
  else
    WRITE(6,*) "initialize_vars_model..."
  endif

  ALLOCATE(lon(nlon))
  ALLOCATE(lat(nlat))
  if (.not. allocated(lev)) then
    ALLOCATE(lev(nlev))
  endif
  ALLOCATE(lon2d(nlon,nlat))
  ALLOCATE(lat2d(nlon,nlat))

  ALLOCATE(dx(nlon,nlat))
  ALLOCATE(dy(nlon,nlat))
  ALLOCATE(phi0(nlon,nlat))
  ALLOCATE(kmt0(nlon,nlat))
  ALLOCATE(SSHclm_m(nlon,nlat))

  ALLOCATE(kmt(nlon,nlat))
  ALLOCATE(pmsk(nlon,nlat))
  ALLOCATE(umsk(nlon,nlat))
  ALLOCATE(vmsk(nlon,nlat))

  ALLOCATE(fcori(nlat))
  ALLOCATE(fcori2d(nlon,nlat))
  ALLOCATE(zb(nlev))
  ALLOCATE(dz(nlev))

  kmt = -1

  vars_model_initialized = .true.

END SUBROUTINE initialize_vars_model

SUBROUTINE set_vars_model

  USE common,       ONLY: r_size, r_omega, pi
  USE params_model, ONLY: nlon, nlat, nlev

  REAL(r_size) :: lon0_360, lonf_360
  INTEGER :: i,j,k
  LOGICAL :: ex
  LOGICAL :: dodebug = .true.

  if (.not. vars_model_initialized) then
    WRITE(6,*) "Not initialized: vars_model_initialized, EXITING..."
    STOP(86)
  else
    WRITE(6,*) "set_vars_model..."
  endif

  ! Set lon and lat, just for completeness (NEMO)
  ! These are mostly still here for backward compatibility
  lon = lon2d(:,NINT(nlat/2.0d0))
  lat = lat2d(NINT(nlon/2.0d0),:)

  !-----------------------------------------------------------------------------
  ! Assign the model grid z-levels
  !-----------------------------------------------------------------------------
  WRITE(6,*) "Assigning NCODA oanl namelist z_lvl levels to LETKF lev() array..."
  if (dodebug) then
    WRITE(6,*) "nlev = ", nlev
    WRITE(6,*) "SHAPE(lev) = ", SHAPE(lev)
    WRITE(6,*) "SIZE(lev) = ", SIZE(lev)
    WRITE(6,*) "lev = ", lev
    WRITE(6,*) "z_lvl = ", z_lvl
  endif
  if (allocated(lev)) then
    lev(1:nlev) = z_lvl(1:nlev)
  else
    STOP("set_vars_model:: lev array is not allocated. EXITING...")
  endif

  !
  ! Coriolis parameter
  !
  WRITE(6,*) "Computing Coriolis parameter..."
  fcori(:) = 2.0d0 * r_omega * sin(lat(:)*pi/180.0d0)
  do j=1,nlat
    do i=1,nlon
      fcori2d(i,j) = 2.0d0 * r_omega * sin(lat2d(i,j)*pi/180.0d0)
    enddo
  enddo

  WRITE(6,*) "Setting lon0,lonf,lat0,latf..."
  lon0 = lon(1)
  lonf = lon(nlon)
  lat0 = lat(1)
  latf = lat(nlat)

  if (dodebug) then
    WRITE(6,*) "common_hycom.f90::set_common_hycom:: lon0,lonf,lat0,latf = ", lon0,lonf,lat0,latf
  endif

  if (lon0 .eq. lonf) then
    WRITE(6,*) "ERROR in vars_model.f90::initialize_vars_model(), lon0==lonf==",lon0
    STOP(25)
  endif

  ! STEVE: for (more) generalized (longitude) grid:
  ! ISSUE: may need to check additional cases
  WRITE(6,*) "Setting wrapgap..."
  if (lon0 .ne. 0 .and. lonf .ne. 360) then
    lon0_360 = MODULO(lon0+360.0,360.0)
    lonf_360 = MODULO(lonf+360.0,360.0)
    wrapgap = abs(lon0_360 - lonf_360)
  else
    wrapgap=0.0
  endif

  vars_model_set = .true.

END SUBROUTINE set_vars_model

END MODULE vars_model

max_stars_repo_name: GEOS-ESM/Ocean-LETKF

max_issues_repo_name: GEOS-ESM/Ocean-LETKF

max_forks_repo_name: GEOS-ESM/Ocean-LETKF


text:
       program  testconvert
       implicit none
       character typepol
       integer l,m,i
       real*8, dimension(:), allocatable:: coeff,coefftrex
       write(6,*) ' Input l, typepol '
       read(5,*) l,typepol
       if(typepol.eq.'h'.or.typepol.eq.'H') then
       m=2*l+1
       else
       m=((1+l)*(2+l))/2
       endif
       allocate(coeff(m),coefftrex(m))
       coefftrex=0
       do i=1,m
       coeff(i)=i
       enddo
       call convertTurboRVBfromtoTREX('t',typepol,l,coeff,coefftrex)
       write(6,*) ' After conversion '
       do i=1,m
       write(6,*) i,coefftrex(i)
       enddo
       coeff=0
       call convertTurboRVBfromtoTREX('f',typepol,l,coeff,coefftrex)
       write(6,*) ' Back to original '
       do i=1,m
       write(6,*)  i,coeff(i)
       if(i.ne.coeff(i)) write(6,*) ' ERROR  f after  t should  be the identity '
       enddo
       stop
       end

       subroutine convertTurboRVBfromtoTREX(scope,typepol,l,coeff,coefftrex)
       implicit none
       character, intent(in) ::  scope,typepol
       real*8, intent(inout) :: coeff(*),coefftrex(*)
       integer, intent(in) :: l
       integer   i,m
!  scope    character*1  input
!  scope='t' or 'T'  translate TurboRVB to TREX convention

!  typepol  character*1  input
!  Convention polynomial 'h' or 'H'  --> Spherical Harmonics
!                        'c' or 'C'  --> Cartesian conventions

!  l integer, input
!  order of the  homogeneous polynomial in x,y,z  or principal quantum number for the 'h' case

!    coeff real*8     input (output)  if scope='t'('f')
!    coefftrex real*8 input (output)  if scope='f'('t')

!  The  coefficients are ordered in a fortran fashion, i.e. the lowest integer definition
!  (e.g. m=-l for the spherical harmonic case) corresponds to  coeff(1) or coefftrex(1)
       if(typepol.eq.'h'.or.typepol.eq.'H') then
         if(scope.eq.'t'.or.scope.eq.'T') then
         select case(l)
           case(0)
           coefftrex(1)=coeff(1)
           case(1)
           coefftrex(1)=coeff(2)
           coefftrex(2)=coeff(3)
           coefftrex(3)=coeff(1)
           case(2)
           coefftrex(1)=coeff(3)
           coefftrex(2)=coeff(4)
           coefftrex(3)=coeff(1)
           coefftrex(4)=coeff(5)
           coefftrex(5)=coeff(2)
           case default
           do i=1,l+1
           coefftrex(i)=coeff(2*l+3-2*i)
           enddo
           do i=1,l
           coefftrex(i+l+1)=coeff(2*i)
           enddo
!          coefftrex(1)=coeff(7)
!          coefftrex(2)=coeff(5)
!          coefftrex(3)=coeff(3)
!          coefftrex(4)=coeff(1)
!          coefftrex(5)=coeff(2)
!          coefftrex(6)=coeff(4)
!          coefftrex(7)=coeff(6)
         end select
         elseif(scope.eq.'f'.or.scope.eq.'F') then
         select case(l)
           case(0)
           coeff(1)=coefftrex(1)
           case(1)
           coeff(2)=coefftrex(1)
           coeff(3)=coefftrex(2)
           coeff(1)=coefftrex(3)
           case(2)
           coeff(3)=coefftrex(1)
           coeff(4)=coefftrex(2)
           coeff(1)=coefftrex(3)
           coeff(5)=coefftrex(4)
           coeff(2)=coefftrex(5)

           case default
           do i=1,l+1
           coeff(2*l+3-2*i)=coefftrex(i)
           enddo
           do i=1,l
           coeff(2*i)=coefftrex(i+l+1)
           enddo
         end select
         else
         write(6,*) ' ERROR case scope not found!!! '
         endif
       elseif(typepol.eq.'c'.or.typepol.eq.'C') then
!        assuming the  identity
         m=((l+1)*(l+2))/2
         if(scope.eq.'t'.or.scope.eq.'T') then
         do i=1,m
         coefftrex(i)=coeff(i)
         enddo
         elseif(scope.eq.'f'.or.scope.eq.'F') then
         do i=1,m
         coeff(i)=coefftrex(i)
         enddo
         else
         write(6,*) ' ERROR case scope not found!!! '
         endif
       else
         write(6,*) ' ERROR case typepol not found!!! '
       endif
       return
       end

max_stars_repo_name: TREX-CoE/trex-io-prototype

max_issues_repo_name: TREX-CoE/trex-io-prototype

max_forks_repo_name: TREX-CoE/trex-io-prototype


text:
      FUNCTION maloc(len)
      INTEGER maloc,len,NG,MEMLEN
      PARAMETER (NG=5,MEMLEN=13*2**(2*NG)/3+14*2**NG+8*NG-100/3)
C     PARAMETER (NG=5,MEMLEN=17*2**(2*NG)/3+18*2**NG+10*NG-86/3)
      INTEGER mem
      DOUBLE PRECISION z
      COMMON /memory/ z(MEMLEN),mem
      if (mem+len+1.gt.MEMLEN) pause 'insufficient memory in maloc'
      z(mem+1)=len
      maloc=mem+2
      mem=mem+len+1
      return
      END

ext: for

max_stars_repo_path: NR-Functions/Numerical Recipes- Example & Functions/Functions/maloc.for


text:
      SUBROUTINE INOUTL

C  Build outlines for nominal ELF in structures 201,202,203;
C  lower left corner of character at 0,0 and height and width of
C  character = 1.  Note that height of character *body* (from
C  topline to bottomline) is usually greater than height of
C  character (from capline to baseline).

      INTEGER  SIZ
      REAL     XA(20), YA(20)

C  capital E
      CALL POPST (201)
      CALL SETRVS ('-0.125, -0.125, 1.125, 1.125, 0.125, 0.125, ' //
     1             ' 1.125,  1.125, 0.125, 0.125, 1.125, 1.125, -0.125',
     2             XA, SIZ)
      CALL SETRVS ('-0.125, 1.125, 1.125, 0.875, 0.875,  0.625, ' //
     1             ' 0.625, 0.375, 0.375, 0.125, 0.125, -0.125, -0.125',
     2             YA, SIZ)
      CALL PPL (SIZ, XA,YA)
      CALL PCLST

C  capital L
      CALL POPST (202)
      CALL SETRVS ('-0.125, -0.125, 0.125, 0.125, 1.125,  1.125, ' //
     1             '-0.125', XA, SIZ)
      CALL SETRVS ('-0.125,  1.125, 1.125, 0.125, 0.125, -0.125, ' //
     1             '-0.125', YA, SIZ)
      CALL PPL (SIZ, XA,YA)
      CALL PCLST

C  capital F
      CALL POPST (203)
      CALL SETRVS ('-0.125, -0.125, 1.125, 1.125,  0.125, 0.125, ' //
     1             ' 1.125,  1.125, 0.125, 0.125, -0.125', XA, SIZ)
      CALL SETRVS ('-0.125, 1.125, 1.125,  0.875,  0.875, 0.625, ' //
     1             ' 0.625, 0.375, 0.375, -0.125, -0.125', YA, SIZ)
      CALL PPL (SIZ, XA,YA)
      CALL PCLST

      END

ext: f


text:
! { dg-do run }
!
! Test the fix for PR38915 in which the character length of the
! temporaries produced in the assignments marked below was set to
! one.
!
! Contributed by Dick Hendrickson <dick.hendrickson@gmail.com>
!
program cg0033_41
  type t
    sequence
    integer i
    character(len=9) c
  end type t
  type (t)  L(3),R(3), LL(4), RR(4)
  EQUIVALENCE (L,LL)
  integer nfv1(3), nfv2(3)
  R(1)%c = '123456789'
  R(2)%c = 'abcdefghi'
  R(3)%c = '!@#$%^&*('
  L%c = R%c
  LL(1:3)%c = R%c
  LL(4)%c = 'QWERTYUIO'
  RR%c = LL%c            ! The equivalence forces a dependency
  L%c = LL(2:4)%c
  if (any (RR(2:4)%c .ne. L%c)) call abort
  nfv1 = (/1,2,3/)
  nfv2 = nfv1
  L%c = R%c
  L(nfv1)%c = L(nfv2)%c  ! The vector indices force a dependency
  if (any (R%c .ne. L%c)) call abort
end

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
An engineering student competition team at UC Davis. A group of Engineering Students (majorly Civil Undergrads) participate in constructing a Concrete Canoe and taking it to a competition each year.  The Canoe is comprised completely out of concrete and reinforcement methods designed by the students each year.  The original purpose of the competition is to teach students the variability and capabilities of concrete.  The team develops lightweight concrete less dense than water which means that the final product will inherently float in water
Competition History

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


subroutine read_ssmi(mype,val_ssmi,ithin,rmesh,jsatid,gstime,&
     infile,lunout,obstype,nread,ndata,nodata,twind,sis,&
     mype_root,mype_sub,npe_sub,mpi_comm_sub,nobs, &
     nrec_start,dval_use)

!$$$  subprogram documentation block
! subprogram:    read_ssmi           read SSM/I  bufr1b data
!   prgmmr: okamoto          org: np23                date: 2003-12-27
!
! abstract:  This routine reads BUFR format SSM/I 1b radiance
!            (brightness temperature) files.  Optionally, the data
!            are thinned to a specified resolution using simple
!            quality control (QC) checks.
!            QC performed in this subroutine are
!             1.obs time check  |obs-anal|<time_window
!             2.remove overlap orbit
!             3.climate check  reject for tb<tbmin or tb>tbmax
!
!            When running the gsi in regional mode, the code only
!            retains those observations that fall within the regional
!            domain
!
! program history log:
!   2003-12-27 okamoto
!   2005-09-08  derber - modify to use input group time window
!   2005-09-28  derber - modify to produce consistent surface info - clean up
!   2005-10-17  treadon - add grid and earth relative obs location to output file
!   2005-10-18  treadon - remove array obs_load and call to sumload
!   2005-11-29  parrish - modify getsfc to work for different regional options
!   2006-02-01  parrish - remove getsfc, refs to sno,sli,sst,isli (not used)
!   2006-02-03  derber  - modify for new obs control and obs count
!   2006-03-07  derber - correct error in nodata count
!   2006-04-27  derber - some efficiency modifications
!   2006-05-19  eliu    - add logic to reset relative weight when all channels not used
!   2006-07-28  derber  - add solar and satellite azimuth angles remove isflg from output
!   2006-08-25  treadon - replace serial bufr i/o with parallel bufr i/o (mpi_io)
!   2006-12-20  Sienkiewicz - add additional satellites f08 f10 f11
!                             set satellite zenith angle (avail. in Wentz data)
!                             85GHz workaround for f08
!   2007-03-01  Tremolet - tdiff definition had disappeared somehow
!   2007-03-01  tremolet - measure time from beginning of assimilation window
!   2007-04-24  derber - define tdiff (was undefined)
!   2008-04-17  safford - rm unused vars
!   2009-04-18  woollen - improve mpi_io interface with bufrlib routines
!   2009-04-21  derber  - add ithin to call to makegrids
!   2011-04-08  li      - (1) use nst_gsi, nstinfo, fac_dtl, fac_tsl and add NSST vars
!                         (2) get zob, tz_tr (call skindepth and cal_tztr)
!                         (3) interpolate NSST Variables to Obs. location (call deter_nst)
!                         (4) add more elements (nstinfo) in data array
!   2011-08-01  lueken  - added module use deter_sfc_mod
!   2012-03-05  akella  - nst now controlled via coupler
!   2013-01-26  parrish - change from grdcrd to grdcrd1 (to allow successful debug compile on WCOSS)
!   2014-05-02  sienkiewicz- modify gross check screening to allow data to be used with bad ch6, if
!                              ch6 data has been turned off - only toss if do85GHz is true
!   2015-02-23  Rancic/Thomas - add thin4d to time window logical
!   2015-10-01  guo     - consolidate use of ob location (in deg)
!   2018-05-21  j.jin   - added time-thinning. Moved the checking of thin4d into satthin.F90.
!
!   input argument list:
!     mype     - mpi task id
!     val_ssmi - weighting factor applied to super obs
!     ithin    - flag to thin data
!     rmesh    - thinning mesh size (km)
!     jsatid   - satellite to read  ex. 'f15'
!     gstime   - analysis time in minutes from reference date
!     infile   - unit from which to read BUFR data
!     lunout   - unit to which to write data for further processing
!     obstype  - observation type to process
!     twind    - input group time window (hours)
!     sis      - satellite/instrument/sensor indicator
!     mype_root - "root" task for sub-communicator
!     mype_sub - mpi task id within sub-communicator
!     npe_sub  - number of data read tasks
!     mpi_comm_sub - sub-communicator for data read
!     nrec_start - first subset with useful information
!
!   output argument list:
!     nread    - number of BUFR SSM/I observations read (after eliminating orbit overlap)
!     ndata    - number of BUFR SSM/I profiles retained for further processing (thinned)
!     nodata   - number of BUFR SSM/I observations retained for further processing (thinned)
!     nobs     - array of observations on each subdomain for each processor
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$  end documentation block
  use kinds, only: r_kind,r_double,i_kind
  use satthin, only: super_val,itxmax,makegrids,map2tgrid,destroygrids, &
      checkob,finalcheck,score_crit
  use satthin, only: radthin_time_info,tdiff2crit
  use obsmod,  only: time_window_max
  use obsmod, only: bmiss
  use radinfo, only: iuse_rad,jpch_rad,nusis,nuchan
  use gridmod, only: diagnostic_reg,regional,rlats,rlons,nlat,nlon,&
      tll2xy,txy2ll
  use constants, only: deg2rad,rad2deg,zero,one,two,three,four,r60inv
  use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen
  use deter_sfc_mod, only: deter_sfc
  use gsi_nstcouplermod, only: nst_gsi,nstinfo
  use gsi_nstcouplermod, only: gsi_nstcoupler_skindepth, gsi_nstcoupler_deter
  use mpimod, only: npe
! use radiance_mod, only: rad_obs_type

  implicit none

! Declare passed variables
  character(len=*),intent(in   ) :: infile,obstype,jsatid
  character(len=20),intent(in  ) :: sis
  integer(i_kind),intent(in   ) :: mype,lunout,ithin,nrec_start
  integer(i_kind),intent(in   ) :: mype_root
  integer(i_kind),intent(in   ) :: mype_sub
  integer(i_kind),intent(in   ) :: npe_sub
  integer(i_kind),intent(in   ) :: mpi_comm_sub
  real(r_kind)   ,intent(in   ) :: rmesh,gstime,twind
  real(r_kind)   ,intent(inout) :: val_ssmi

  integer(i_kind),dimension(npe),intent(inout):: nobs
  integer(i_kind),intent(inout):: nread

  integer(i_kind),intent(inout):: ndata,nodata
  logical        ,intent(in   ):: dval_use

! Declare local parameters
  integer(i_kind),parameter :: n1bhdr=14
  integer(i_kind),parameter :: maxchanl=30

  integer(i_kind),parameter :: ntime=8      !time header
  integer(i_kind),parameter :: nloc=5       !location dat used for ufbint()
  integer(i_kind),parameter :: maxscan=64   !possible max of scan positons
  real(r_kind),parameter:: r360=360.0_r_kind
  real(r_kind),parameter:: tbmin=70.0_r_kind
  real(r_kind),parameter:: tbmax=320.0_r_kind
  character(80),parameter:: hdr1b='SAID YEAR MNTH DAYS HOUR MINU SECO ORBN'   !use for ufbint()
  character(40),parameter:: str1='CLAT CLON SFTG POSN SAZA'   !use for ufbint()
  character(40),parameter:: str2='TMBR'                  !use for ufbrep()

! Declare local variables
  logical ssmi,assim
  logical outside,iuse

  character(8) subset

  integer(i_kind):: i,k,ntest,ireadsb,ireadmg,irec,next
  integer(i_kind):: iret,idate,nchanl
  integer(i_kind):: isflg,nreal,idomsfc
  integer(i_kind):: nmind,itx,nele,itt
  integer(i_kind):: iskip,maxinfo
  integer(i_kind):: lnbufr
  integer(i_kind):: ilat,ilon
  integer(i_kind),allocatable,dimension(:)::nrec

  real(r_kind) sfcr

  real(r_kind) pred
  real(r_kind) sstime,tdiff,t4dv
  real(r_kind) crit1,dist1
  real(r_kind),allocatable,dimension(:,:):: data_all

  real(r_kind) disterr,disterrmax,dlon00,dlat00,cdist

!  ---- bufr argument -----
  real(r_double),dimension(n1bhdr):: bfr1bhdr
  real(r_double),dimension(nloc,maxscan) :: midat  !location data from str1
  real(r_double),dimension(maxchanl*maxscan) :: mirad !TBB from str2

  integer(i_kind) :: nscan,jc,bufsat,js,ij,npos,n
  integer(i_kind),dimension(5):: iobsdate
  real(r_kind):: tb19v,tb22v,tb85v,si85,flgch,q19
  real(r_kind),dimension(maxchanl):: tbob
  real(r_kind),dimension(0:3):: sfcpct
  real(r_kind),dimension(0:3):: ts
  real(r_kind),dimension(0:4):: rlndsea
  real(r_kind) :: tsavg,vty,vfr,sty,stp,sm,sn,zz,ff10
  real(r_kind) :: zob,tref,dtw,dtc,tz_tr

  real(r_kind):: dlat,dlon,dlon_earth,dlat_earth
  real(r_kind):: dlon_earth_deg,dlat_earth_deg
  real(r_kind):: ssmi_def_ang,ssmi_zen_ang  ! default and obs SSM/I zenith ang
  logical  do85GHz, ch6, ch7
  real(r_kind)    :: ptime,timeinflat,crit0
  integer(i_kind) :: ithin_time,n_tbin,it_mesh

!**************************************************************************
! Initialize variables
  maxinfo=31
  lnbufr = 15
  disterrmax=zero
  ntest=0

  nchanl = 30
  ndata  = 0
  nodata = 0
  nread  = 0
  ssmi_def_ang = 53.1_r_kind

  ilon=3
  ilat=4

  if(nst_gsi>0) then
     call gsi_nstcoupler_skindepth(obstype, zob)         ! get penetration depth (zob) for the obstype
  endif

! Set various variables depending on type of data to be read

  ssmi  = obstype  == 'ssmi'

  if ( ssmi ) then
     nscan  = 64   !for A-scan
!    nscan  = 128  !for B-scan
     nchanl = 7
     if(jsatid == 'f08')bufsat=241
     if(jsatid == 'f10')bufsat=243
     if(jsatid == 'f11')bufsat=244
     if(jsatid == 'f13')bufsat=246
     if(jsatid == 'f14')bufsat=247
     if(jsatid == 'f15')bufsat=248
     rlndsea(0) = zero
     rlndsea(1) = 30._r_kind
     rlndsea(2) = 30._r_kind
     rlndsea(3) = 30._r_kind
     rlndsea(4) = 100._r_kind
  end if

! If all channels of a given sensor are set to monitor or not
! assimilate mode (iuse_rad<1), reset relative weight to zero.
! We do not want such observations affecting the relative
! weighting between observations within a given thinning group.

  assim=.false.
  ch6=.false.
  ch7=.false.
  search: do i=1,jpch_rad
     if (nusis(i)==sis) then
        if (iuse_rad(i)>=0) then
           if (iuse_rad(i)>0) assim=.true.
           if (nuchan(i)==6) ch6=.true.
           if (nuchan(i)==7) ch7=.true.
           if (assim.and.ch6.and.ch7) exit
        endif
     endif
  end do search
  if (.not.assim) val_ssmi=zero

  do85GHz = .not. assim .or. (ch6.and.ch7)

  call radthin_time_info(obstype, jsatid, sis, ptime, ithin_time)
  if( ptime > 0.0_r_kind) then
     n_tbin=nint(2*time_window_max/ptime)
  else
     n_tbin=1
  endif
! Make thinning grids
  call makegrids(rmesh,ithin,n_tbin=n_tbin)

! Open unit to satellite bufr file
  open(lnbufr,file=trim(infile),form='unformatted')
  call openbf(lnbufr,'IN',lnbufr)
  call datelen(10)

! Allocate arrays to hold data
  if(dval_use)maxinfo=maxinfo+2
  nreal  = maxinfo + nstinfo
  nele   = nreal   + nchanl
  allocate(data_all(nele,itxmax),nrec(itxmax))

! Big loop to read data file
  nrec=999999
  irec=0
  next=0
  read_subset: do while(ireadmg(lnbufr,subset,idate)>=0)
     irec=irec+1
     if(irec < nrec_start) cycle read_subset
     next=next+1
     if(next == npe_sub)next=0
     if(next /= mype_sub)cycle
     read_loop: do while (ireadsb(lnbufr)==0)

! ----- Read header record to extract satid,time information
!       SSM/I data are stored in groups of nscan, hence the loop.
        call ufbint(lnbufr,bfr1bhdr,ntime,1,iret,hdr1b)

!       Extract satellite id.  If not the one we want, read next record
        if(nint(bfr1bhdr(1)) /= bufsat) cycle read_subset

!       calc obs seqential time  If time outside window, skip this obs
        iobsdate(1:5) = bfr1bhdr(2:6) !year,month,day,hour,min
        call w3fs21(iobsdate,nmind)
        t4dv=(real(nmind-iwinbgn,r_kind) + real(bfr1bhdr(7),r_kind)*r60inv)*r60inv
        sstime=real(nmind,r_kind) + real(bfr1bhdr(7),r_kind)*r60inv
        tdiff=(sstime-gstime)*r60inv
        if (l4dvar.or.l4densvar) then
           if (t4dv<zero .OR. t4dv>winlen) cycle read_loop
        else
           if(abs(tdiff) > twind)  cycle read_loop
        endif

! ----- Read header record to extract obs location information
!       SSM/I data are stored in groups of nscan, hence the loop.

        call ufbint(lnbufr,midat,nloc,nscan,iret,str1)

!---    Extract brightness temperature data.  Apply gross check to data.
!       If obs fails gross check, reset to missing obs value.

        call ufbrep(lnbufr,mirad,1,nchanl*nscan,iret,str2)

        ij=0
        scan_loop:   do js=1,nscan

!          Regional case
           dlat_earth = midat(1,js)  !deg
           dlon_earth = midat(2,js)  !deg
           if(abs(dlat_earth)>90.0_r_kind .or. abs(dlon_earth)>r360) cycle scan_loop
           if(dlon_earth< zero) dlon_earth = dlon_earth+r360
           if(dlon_earth==r360) dlon_earth = dlon_earth-r360
           dlat_earth_deg = dlat_earth
           dlon_earth_deg = dlon_earth
           dlat_earth = dlat_earth*deg2rad
           dlon_earth = dlon_earth*deg2rad

           if(regional)then
              call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside)
              if(diagnostic_reg) then
                 call txy2ll(dlon,dlat,dlon00,dlat00)
                 ntest=ntest+1
                 cdist=sin(dlat_earth)*sin(dlat00)+cos(dlat_earth)*cos(dlat00)* &
                      (sin(dlon_earth)*sin(dlon00)+cos(dlon_earth)*cos(dlon00))
                 cdist=max(-one,min(cdist,one))
                 disterr=acos(cdist)*rad2deg
                 disterrmax=max(disterrmax,disterr)
              end if

!             Check to see if in domain
!cggg should this be cycle scan_loop?
              if(outside) cycle read_loop

!          Global case
           else
              dlat = dlat_earth
              dlon = dlon_earth
              call grdcrd1(dlat,rlats,nlat,1)
              call grdcrd1(dlon,rlons,nlon,1)
           endif

!  If available, set value of ssmi zenith angle
!
           if (midat(5,js) < bmiss ) then
              ssmi_zen_ang = midat(5,js)
           else
              ssmi_zen_ang = ssmi_def_ang
           endif

!          Transfer observed brightness temperature to work array.
!          If any temperature exceeds limits, reset observation to "bad" value
!          mirad(1:maxchanl*nscan) => data1b(1:6+nchanl)
           iskip=0
           do jc=1,nchanl
              ij = ij+1
              if(mirad(ij)<tbmin .or. mirad(ij)>tbmax ) then
                 iskip = iskip + 1
                 if(jc == 1 .or. jc == 3)iskip=iskip+nchanl
                 if(jc == 6 .and. do85GHz)iskip=iskip+nchanl    ! skip on bad ch6 only if using 85GHz data
              else
                 nread=nread+1
              end if
              tbob(jc) = mirad(ij)

           end do   !jc_loop
           if(iskip >= nchanl)  cycle scan_loop  !if all ch for any position is bad, skip
           flgch = iskip*two   !used for thinning priority range 0-14

!          Map obs to thinning grid
           crit0 = 0.01_r_kind
           timeinflat=6.0_r_kind
           call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh)
           call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh)
           if(.not. iuse)cycle scan_loop

!          Locate the observation on the analysis grid.  Get sst and land/sea/ice
!          mask.

!       isflg    - surface flag
!                  0 sea
!                  1 land
!                  2 sea ice
!                  3 snow
!                  4 mixed

           call deter_sfc(dlat,dlon,dlat_earth,dlon_earth,t4dv,isflg,idomsfc,sfcpct, &
              ts,tsavg,vty,vfr,sty,stp,sm,sn,zz,ff10,sfcr)

           crit1 = crit1 + rlndsea(isflg)
           call checkob(dist1,crit1,itx,iuse)
           if(.not. iuse)cycle scan_loop

           if (do85GHz) then  ! do regular checks if 85 GHz available

!    ---- Set data quality predictor for initial qc -------------
!      -  simple si index : taken out from ssmiqc()
!            note! it exclude emission rain
              tb19v=tbob(1);  tb22v=tbob(3); tb85v=tbob(6)
              if(isflg/=0)  then !land+snow+ice
                 si85 = 451.9_r_kind - 0.44_r_kind*tb19v - 1.775_r_kind*tb22v + &
                    0.00574_r_kind*tb22v*tb22v - tb85v
              else    !sea
                 si85 = -174.4_r_kind + 0.715_r_kind*tb19v + 2.439_r_kind*tb22v -  &
                    0.00504_r_kind*tb22v*tb22v - tb85v
              end if

!             Compute "score" for observation.  All scores>=0.0.  Lowest score is "best"
              pred = abs(si85)*three  !range: 0 to 30

           else              ! otherwise do alternate check for rain

              if (isflg/=0) then     ! just try to scren out land pts.
                 pred = 50_r_kind
              else
                 tb19v=tbob(1);  tb22v=tbob(3);
                 if (tb19v < 288.0_r_kind .and. tb22v < 288.0_r_kind) then
                    q19 = -6.723_r_kind * ( log(290.0_r_kind - tb19v)  &
                         - 2.850_r_kind - 0.405_r_kind* log(290.0_r_kind - tb22v))
                    pred = min(75._r_kind * q19,50.)  ! scale 0.4mm -> pred ~ 30
                 else
                    pred = 50_r_kind      ! default if Tb 19/22 > 288
                 endif
              endif
           endif

!          Compute final "score" for observation.  All scores>=0.0.
!          Lowest score is "best"
           crit1 = crit1 + pred

           call finalcheck(dist1,crit1,itx,iuse)
           if(.not. iuse)cycle scan_loop

           npos = (midat(4,js)-one)/four+one !original scan position 1.0->253.0 =4*(n-1)+1
!
!          interpolate NSST variables to Obs. location and get dtw, dtc, tz_tr
!
           if(nst_gsi>0) then
              tref  = ts(0)
              dtw   = zero
              dtc   = zero
              tz_tr = one
              if(sfcpct(0)>zero) then
                 call gsi_nstcoupler_deter(dlat_earth,dlon_earth,t4dv,zob,tref,dtw,dtc,tz_tr)
              endif
           endif

!          Transfer observation parameters to output array.
           data_all( 1,itx) = bufsat              ! satellite id
           data_all( 2,itx) = t4dv                ! time diff between obs and anal (min)
           data_all( 3,itx) = dlon                ! grid relative longitude
           data_all( 4,itx) = dlat                ! grid relative latitude
           data_all( 5,itx) = ssmi_zen_ang*deg2rad ! local zenith angle (rad)
           data_all( 6,itx) = 999.00_r_kind       ! local azimuth angle (missing)
           data_all( 7,itx) = zero                ! look angle (rad)
!+>        data_all( 7,itx) =  45.0*deg2rad       ! look angle (rad)
           data_all( 8,itx) = npos                ! scan position 1->64
           data_all( 9,itx) = zero                ! solar zenith angle (deg) : not used
           data_all(10,itx) = 999.00_r_kind       ! solar azimuth angle (missing) : not used
           data_all(11,itx) = sfcpct(0)           ! sea percentage of
           data_all(12,itx) = sfcpct(1)           ! land percentage
           data_all(13,itx) = sfcpct(2)           ! sea ice percentage
           data_all(14,itx) = sfcpct(3)           ! snow percentage
           data_all(15,itx)= ts(0)                ! ocean skin temperature
           data_all(16,itx)= ts(1)                ! land skin temperature
           data_all(17,itx)= ts(2)                ! ice skin temperature
           data_all(18,itx)= ts(3)                ! snow skin temperature
           data_all(19,itx)= tsavg                ! average skin temperature
           data_all(20,itx)= vty                  ! vegetation type
           data_all(21,itx)= vfr                  ! vegetation fraction
           data_all(22,itx)= sty                  ! soil type
           data_all(23,itx)= stp                  ! soil temperature
           data_all(24,itx)= sm                   ! soil moisture
           data_all(25,itx)= sn                   ! snow depth
           data_all(26,itx)= zz                   ! surface height
           data_all(27,itx)= idomsfc + 0.001_r_kind ! dominate surface type
           data_all(28,itx)= sfcr                 ! surface roughness
           data_all(29,itx)= ff10                 ! ten meter wind factor
           data_all(30,itx)= dlon_earth_deg       ! earth relative longitude (degrees)
           data_all(31,itx)= dlat_earth_deg       ! earth relative latitude (degrees)
           if(dval_use)then
              data_all(32,itx)= val_ssmi
              data_all(33,itx)= itt
           end if

           if(nst_gsi>0) then
              data_all(maxinfo+1,itx) = tref       ! foundation temperature
              data_all(maxinfo+2,itx) = dtw        ! dt_warm at zob
              data_all(maxinfo+3,itx) = dtc        ! dt_cool at zob
              data_all(maxinfo+4,itx) = tz_tr      ! d(Tz)/d(Tr)
           endif

           do i=1,nchanl
              data_all(i+nreal,itx)=tbob(i)
           end do
           nrec(itx)=irec
        end do  scan_loop    !js_loop end

     end do read_loop
  end do read_subset
  call closbf(lnbufr)

! If multiple tasks read input bufr file, allow each tasks to write out
! information it retained and then let single task merge files together

  call combine_radobs(mype_sub,mype_root,npe_sub,mpi_comm_sub,&
     nele,itxmax,nread,ndata,data_all,score_crit,nrec)

  write(6,*) 'READ_SSMI: after combine_obs, nread,ndata is ',nread,ndata

! Allow single task to check for bad obs, update superobs sum,
! and write out data to scratch file for further processing.
  if (mype_sub==mype_root.and.ndata>0) then

!    Identify "bad" observation (unreasonable brightness temperatures).
!    Update superobs sum according to observation location

     do n=1,ndata
        do i=1,nchanl
           if(data_all(i+nreal,n) > tbmin .and. &
              data_all(i+nreal,n) < tbmax)nodata=nodata+1
        end do
     end do
     if(dval_use .and. assim)then
        do n=1,ndata
           itt=nint(data_all(33,n))
           super_val(itt)=super_val(itt)+val_ssmi
        end do
     end if

!    Write final set of "best" observations to output file
     call count_obs(ndata,nele,ilat,ilon,data_all,nobs)
     write(lunout) obstype,sis,nreal,nchanl,ilat,ilon
     write(lunout) ((data_all(k,n),k=1,nele),n=1,ndata)

  endif

! Deallocate data arrays
  deallocate(data_all,nrec)

! Deallocate satthin arrays
1000 continue
  call destroygrids

  if(diagnostic_reg .and. ntest>0 .and. mype_sub==mype_root) &
     write(6,*)'READ_SSMI:  mype,ntest,disterrmax=',&
        mype,ntest,disterrmax

! End of routine
 return
end subroutine read_ssmi


text:
c     Copyright INRIA
      subroutine kronr(a,ia,ma,na,b,ib,mb,nb,pk,ik)
c!but
c ce sous programme genere le produit de kronecker de deux matrices
c  a et b  pk(i,j)=a(i,j)*b
c!liste d'appel
c      subroutine kronr(a,ia,ma,na,b,ib,mb,nb,pk,ik)
c     double precision a(ia,na),b(ib,nb),pk(ik,*)
c     integer ia,ma,na,ib,mb,nb,ik
c
c     a : tableau contenant la matrice a
c     ia : increment entre 2 elements consecutif d'une meme
c             ligne de a
c     ma : nombre de lignes de a
c     na : nombre de colonnes dea
c     b,ib,mb,nb : definitions similaires pour la matrice b
c     pk : tableau contenant la matrice resultat pk
c     ik : increment entre deux elements consecutifs d'une meme
c          ligne de pk
c!
      double precision a(*),b(*),pk(*)
      integer ia,ma,na,ib,mb,nb,ik,ka,kb,kk,ka1,kk1
c
      ka1=1-ia
      kk1=-nb
      do 30 ja=1,na
         kb=1
         ka1=ka1+ia
         kk1=kk1+nb
         do 20 jb=1,nb
            ka=ka1
            kk=1+(jb-1+kk1)*ik
            do 10 i=1,ma
               call dcopy(mb,b(kb),1,pk(kk),1)
               call dscal(mb,a(ka),pk(kk),1)
               kk=kk+mb
               ka=ka+1
 10         continue
            kb=kb+ib
 20      continue
 30   continue
      return
      end

max_stars_repo_name: alpgodev/numx

max_issues_repo_name: alpgodev/numx

max_forks_repo_name: alpgodev/numx


module argparse_test
  use fruit
  use types_mod
  implicit none

contains

  subroutine test_split_string
    use types_mod
    use argparse_mod
    implicit none

    character(100) :: string_in, string_out1, string_out2

    string_in = 'this=that'
    call split_string( string_in, string_out1, string_out2, '=' )

    call assert_true( trim(string_out1) == 'this', "split_string this=that 1" )
    call assert_true( trim(string_out2) == 'that', "split_string this=that 2" )

    string_in = 'this!that'
    call split_string( string_in, string_out1, string_out2, '=' )

    call assert_true( trim(string_out1) == 'this!that', "split_string this!that 1" )
    call assert_true( trim(string_out2) == '', "split_string this!that 2" )

    string_in = 'this!that='
    call split_string( string_in, string_out1, string_out2, '=' )

    call assert_true( trim(string_out1) == 'this!that', "split_string this!that= 1" )
    call assert_true( trim(string_out2) == '', "split_string this!that= 2" )

    string_in = '=this!that'
    call split_string( string_in, string_out1, string_out2, '=' )

    call assert_true( trim(string_out1) == '', "split_string =this!that 1" )
    call assert_true( trim(string_out2) == 'this!that', "split_string =this!that 2" )

  end subroutine test_split_string

  subroutine test_check_name_value_pair_validity
    use types_mod
    use argparse_mod
    implicit none

    logical :: name_valid, value_valid

    call check_name_value_pair_validity( '--test', 'hello', name_valid, value_valid )

    call assert_true( name_valid .eqv. .true., "check_name_value_pair_validity --test=hello name")
    call assert_true( value_valid .eqv. .true., "check_name_value_pair_validity --test=hello value")

    call check_name_value_pair_validity( '-test', 'hello', name_valid, value_valid )

    call assert_true( name_valid .eqv. .false., "check_name_value_pair_validity -test=hello name")
    call assert_true( value_valid .eqv. .true., "check_name_value_pair_validity -test=hello value")

    call check_name_value_pair_validity( '--test', '', name_valid, value_valid )

    call assert_true( name_valid .eqv. .true., "check_name_value_pair_validity --test= name")
    call assert_true( value_valid .eqv. .false., "check_name_value_pair_validity --test= value")

    call check_name_value_pair_validity( '-test', ' ', name_valid, value_valid )

    call assert_true( name_valid .eqv. .false., "check_name_value_pair_validity -test=  name")
    call assert_true( value_valid .eqv. .false., "check_name_value_pair_validity -test=  value")

    call check_name_value_pair_validity( '--help', '', name_valid, value_valid )

    call assert_true( name_valid .eqv. .true., "check_name_value_pair_validity --help name")
    call assert_true( value_valid .eqv. .true., "check_name_value_pair_validity --help value")

    call check_name_value_pair_validity( '--help', 'test', name_valid, value_valid )

    call assert_true( name_valid .eqv. .true., "check_name_value_pair_validity --help=test name")
    call assert_true( value_valid .eqv. .true., "check_name_value_pair_validity --help=test value")

  end subroutine test_check_name_value_pair_validity

end module argparse_test


text:
C$Procedure      M2GMCH ( Match a META/2 template including groups )

      SUBROUTINE M2GMCH ( TEMP,    THNWDS,
     .                    STRING,  SBEG,   REASON, CUTOFF,
     .                    PSSTHN,  M2CODE, SCORE,  CAUSE   )
      IMPLICIT NONE

C$ Abstract
C
C      This routine will match a META/2 template that contains no
C      qualified @then directives.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C      The META/2 book.
C
C$ Keywords
C
C     PARSING
C     STRING
C     UTILITY
C
C$ Declarations

      INTEGER               LBCELL
      PARAMETER           ( LBCELL = -5 )

      CHARACTER*(*)         TEMP
      CHARACTER*(*)         THNWDS  ( LBCELL : * )
      CHARACTER*(*)         STRING
      INTEGER               SBEG
      LOGICAL               REASON
      INTEGER               CUTOFF
      LOGICAL               PSSTHN
      INTEGER               M2CODE
      INTEGER               SCORE
      CHARACTER*(*)         CAUSE   ( 2 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     TEMP       I   A META/2 template
C     THNWDS     I   A cell of initial keywords for a following @then
C     STRING     I   A candidate META/2 sentence.
C     SBEG       I   Where to start processing this sentence
C     REASON     I   Flag indicating diagnostics should be produced.
C     CUTOFF     I   Threshold used for spelling error diagnostics.
C     PSSTHN     O   Flag to indicate we made it past a @then
C     M2CODE     O   META/2 code indicating how a match failed.
C     SCORE      O   a measure of how well STRING matched TEMP.
C     CAUSE      O   Diagnostic message if requested for non-matches.
C
C$ Detailed_Input
C
C     TEMP       is a META/2 template to be compared with a portion
C                of the candidate input sentence.
C
C     THNWDS     is a cell containing KEYWORDS that may be used as
C                terminators for the entire template.  Typically
C                this cell will contain the initial keywords of
C                a class of templates that can be branched to from
C                this template.
C
C     STRING     A string, a substring of which ( STRING(SBEG:) )
C                should be compared with the input META/2 template.
C
C     SBEG       is the beginning of the substring that should be
C                compared with TEMP.
C
C     REASON     Is a logical flag, that should be set to .TRUE.
C                if the user wishes to have error mismatch diagnostics
C                to be returned by this routine.
C
C     CUTOFF     is a parameter used to determine how close words
C                of STRING must match up with keywords in TEMP
C                in order to be diagnosed as spelling errors.
C                Ranges from 0 to 100 are acceptable.  A "good" range
C                of values is from from 65 to 75.
C
C$ Detailed_Output
C
C     SBEG       if the match is successful, SBEG will be set to the
C                first word of the input string that follows the
C                matched substring. ( Note that words in THNWDS do
C                not qualify as part of the template, but merely
C                serve to delimit the ends of variable length
C                templates. Thus if one of these words was actually
C                used to delimit the end of TEMP, SBEG will point to
C                the beginning of that word in STRING.)
C
C     PSSTHN     is set only if the template matches up to an
C                an unqualified @then directive.  In such a case
C                PSSTHN will be set to .TRUE.  Otherwise it will not
C                be changed from its input value.
C
C     M2CODE     is an integer META/2 code that indicates how an attempt
C                to match the input failed.  If the match was successful
C                M2CODE will be returned as zero.  Otherwise it will
C                be returned with a positive value.  Possible values
C                and meanings are:
C
C
C
C     SCORE      is a measure of how well STRING matched TEMP.  This
C                is useful primarily when looking through several
C                templates, none of which yield an M2CODE of zero.  In
C                this case, the template with the highest SCORE is
C                likely to be the template the input string was
C                "intended" to match.
C
C     CAUSE      If REASON is set to .TRUE. and the match fails
C                (M2CODE .NE. 0 ), this string will contain a
C                description of the suspected cause of the match
C                failure.  Moreover, the input string will be "marked"
C                at the location of the match failure.
C
C$ Files
C
C     None.
C
C$ Exceptions
C
C     1)  If the number of delimiting keywords is greater than 64 a
C         SPICE TOOLKIT error will be SIGERRled.
C
C         SPICE(TOOMANYKEYWORDS)
C
C         Delimiting keywords are:
C
C         a) Keywords that immediately follow group templates.
C         b) Keywords that are the initial keywords of a simple template
C            contained within a group template.
C         c) The keywords passed to the routine in the cell THNWDS.
C
C$ Particulars
C
C     This routine allows one to compare strings with those META/2
C     language templates that do not end with a qualified-'@then'.
C     Moreover, it serves as the principle tool for matching the
C     various pieces of full META/2 templates.  If a match occurs
C     the remainder of the string can be compared with the templates
C     pointed to by the @then  directive.
C
C
C$ Examples
C
C     None.
C
C$ Restrictions
C
C     The maximum number of delimiting keywords is 64.
C
C     No checks are made to see if the template supplied is in fact
C     a valid META/2 template.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber     (JPL)
C     I.M. Underwood (JPL)
C
C$ Version
C
C-     META/2 Configured Version 2.1.0, 08-NOV-2005 (BVS)
C
C        Updated to remove non-standard use of duplicate arguments
C        in FNDNWD calls.
C
C-     META/2 Configured Version 2.0.0, 9-MAY-1994 (WLT)
C
C         This is the configured version of the Command Loop
C         software as of May 9, 1994
C
C
C-     META/2 Configured Version 2.0.0, 9-MAY-1994 (WLT)
C
C         Added an extra blank after a carriage return "/cr"
C         substring in
C
C           DIAGNS = 'I was trying to match part of the input '  ...
C           //       'string with one of the expresions listed ' ...
C           //       'here: /cr/cr '                             ...
C           //        SUBTMP(1:RTRIM(SUBTMP))                    ...
C           //       './cr/cr The expression that came closest ' ...
C           //       'was: /cr/cr, '
C
C-     META/2 Configured Version 1.0.0, 3-MAY-1994 (WLT)
C
C         This is the configured version of META/2
C         software as of May 3, 1994
C
C
C     Beta Version 1.0.0, 19-MAY-1988 (WLT) (IMU)
C
C-&

C
C     SPICELIB functions
C
      INTEGER               BSRCHI
      INTEGER               CARDC
      INTEGER               CARDI
      INTEGER               QLSTNB
      INTEGER               LSTLTI
      INTEGER               NCPOS
      INTEGER               POS
      INTEGER               RTRIM
      INTEGER               SIZEC
      INTEGER               UPTO
      LOGICAL               M2KEYW
      LOGICAL               MATCH

C
C     Local variables
C
      LOGICAL               PASS1

      CHARACTER*32          TERMS  ( LBCELL : 64 )

      INTEGER               INDXES ( LBCELL : 64 )

      INTEGER               TLEN
      INTEGER               SIZE

      INTEGER               I
      INTEGER               J
      INTEGER               K
      INTEGER               TMPJ

      INTEGER               TBEG
      INTEGER               TEND

      LOGICAL               MORE
      LOGICAL               GROUP
      LOGICAL               SIMPLE
      CHARACTER*8           LAST

      INTEGER               POSITN
      CHARACTER*32          LABEL

      INTEGER               EO
      INTEGER               BO
      LOGICAL               OPTDIR

      INTEGER               BW
      INTEGER               EW

      INTEGER               FEWEST
      INTEGER               MOST

      INTEGER               GMATCH
      INTEGER               BSCORE
      INTEGER               BEGOFG
      INTEGER               ENDOFG
      INTEGER               AFTERG

      INTEGER               BS
      INTEGER               ES

      INTEGER               A
      INTEGER               B
      INTEGER               E
      INTEGER               BLSTWD
      INTEGER               CLSTWD
      INTEGER               ELSTWD

      CHARACTER*32          KEYWDS ( LBCELL : 64 )
      CHARACTER*32          SWORDS ( LBCELL : 64 )

      INTEGER               T1CODE
      INTEGER               TSCORE

      INTEGER               LOC

      INTEGER               BDIAGS
      INTEGER               EDIAGS

      INTEGER               BCODE

      CHARACTER*1024        SUBTMP

      LOGICAL               REDIAG
      LOGICAL               VTEMPL

      SAVE

      DATA                  PASS1   / .TRUE. /

C
C     If this is the first pass through this routine, set the size of
C     the cells TERMS and INDXES
C
      IF ( PASS1 ) THEN

         PASS1 = .FALSE.

         CALL SSIZEC ( 64, TERMS  )
         CALL SSIZEI ( 64, INDXES )
         CALL SSIZEC ( 64, KEYWDS )
         CALL SSIZEC ( 64, SWORDS )

      END IF

C
C     Clear out the parse table.
C
      CALL M2PCLR

C
C     Collect the list of potential terminating keywords.
C
      CALL M2TERM ( TEMP, TERMS, INDXES )

C
C     Append all of the '@then(*)'-keywords to the list of terminators.
C
      IF ( CARDC(TERMS) + CARDC (THNWDS) .GE. SIZEC(TERMS) - 2 ) THEN

         CALL CHKIN  ( 'M2GMCH' )
         CALL SIGERR ( 'SPICE(TOOMANYKEYWORDS)' )
         CALL CHKOUT ( 'M2GMCH' )
         RETURN

      END IF

      TLEN = LEN   ( TEMP  ) + 1
      J    = CARDC ( TERMS ) + 1

      DO I = 1, CARDC( THNWDS )
         TERMS (J) = THNWDS(I)
         INDXES(J) = TLEN
         J         = J + 1
      END DO

C
C     Append a '@end' and a '}' to the end of the terminators, and
C     adjust the cardinality of the TERMS cell
C
      TERMS (J) = '@end'
      INDXES(J) = TLEN
      J         = J + 1

      TERMS (J) = '}'
      INDXES(J) = TLEN
      SIZE      = CARDC(TERMS) + CARDC(THNWDS) + 2

      CALL SCARDC ( SIZE, TERMS  )
      CALL SCARDI ( SIZE, INDXES )

C
C     This routine will only use the portion of the template up
C     to a qualified @then.
C
      CALL M2THNQ ( TEMP, POSITN, LABEL )

      IF ( POSITN .LE. LEN ( TEMP ) ) THEN
         TEMP(POSITN:) = ' '
      END IF

C
C     Now initialize pointers and the loop control variable MORE so
C     that we can start the loop.
C
      TBEG = 1
      TEND = 1

      MORE = .TRUE.

      DO WHILE ( MORE )
C
C     As long as we are not told to exit
C
C        Look at the next word,
C
         CALL FNDNWD ( TEMP, TBEG, BW, EW )

         IF ( BW .EQ. 0 ) THEN

C
C           There wasn't a next word.  There is nothing left to do.
C           We set MORE to .FALSE. so that we can exit the loop.
C
            MORE   = .FALSE.
            GROUP  = .FALSE.
            SIMPLE = .FALSE.

         ELSE IF ( TEMP(BW:EW) .EQ. '@then' ) THEN

C
C           We have an unqualified @then directive.  This means that
C           we are on the right track as far as determining what
C           command we are working on.  Set the PASSED-A-@then flag
C           (PSSTHN) to .TRUE. and the other candidates to .FALSE.
C
            PSSTHN = .TRUE.
            GROUP  = .FALSE.
            SIMPLE = .FALSE.

            TBEG   = EW + 1
            TEND   = TBEG

         ELSE IF ( MATCH( TEMP(BW:EW), '(%*:%*){' ) ) THEN

C
C           We are about to enter a group template.  Determine
C           the FEWEST number of simple templates in the group
C           that must match and the MOST that we will check.
C
            CALL M2BEGR ( TEMP, BW, EW, FEWEST, MOST )

            GROUP  = .TRUE.
            SIMPLE = .FALSE.
            LAST   = 'GROUP'

C
C           Set up the pointers for looking for the simple
C           templates within this group.
C
            TBEG   = EW + 1
            TEND   = TBEG

         ELSE

C
C           The only possible candidate is a simple template.
C
            GROUP  = .FALSE.
            SIMPLE = .TRUE.
            TBEG   = BW
            LAST   = 'SIMPLE'

         END IF

         IF ( GROUP ) THEN

C
C           Set up the initial values for this group.  We need
C
C           1)  The number of simple template matches so far for
C               this group.
C
            GMATCH = 0

C
C           2)  A best score of the simple templates checked so far.
C
            BSCORE = -1

C
C           3)  A temporary place to store the M2CODE returned for
C               a simple template of this group.
C
            T1CODE = 0

C
C           4)  The position in the full template to jump to when we are
C               done with this template, the beginning and the end of
C               the group
C
            BEGOFG = TBEG
            ENDOFG = UPTO ( TEMP, ' }', TBEG  )
            AFTERG = ENDOFG + 3

C
C           Make sure there is a viable simple template within this
C           group.
C
            BS = NCPOS( TEMP,  ' ',    BEGOFG        )
            ES = MIN  ( UPTO ( TEMP, ' | ', BEGOFG  ),
     .                  UPTO ( TEMP, ' } ', BEGOFG  )  )

            IF (      ( BS          .EQ. 0      )
     .           .OR. ( BS          .GE. ES     )
     .           .OR. ( TEMP(BS:BS) .EQ. '}'    )
     .           .OR. ( ES          .GT. ENDOFG ) ) THEN

               GROUP = .FALSE.
            END IF

C
C           Finally, if FEWEST is 1 or 0,
C           remove the '}' that has index equal to the index
C           of the '}' that is the terminator of this group.
C
            IF ( FEWEST .LE. 1 ) THEN
               LOC = BSRCHI ( ENDOFG+2, CARDI(INDXES), INDXES(1) )

               IF ( LOC .NE. 0 ) THEN
                  CALL REMLAI ( 1, LOC, INDXES(1), CARDI(INDXES) )
                  CALL REMLAC ( 1, LOC, TERMS(1),  CARDC(TERMS)  )

                  CALL SCARDC ( CARDC(TERMS)  - 1, TERMS      )
                  CALL SCARDI ( CARDI(INDXES) - 1, INDXES     )
               END IF
            END IF

            DO WHILE ( GROUP )

C
C              We've got a viable simple template for this group.
C
C              If it ends with a variable template find out what the
C              possible terminating words are.
C
               A = 0
               B = 0

               CALL FNDPTK ( TEMP, ' ', ES + 1, BLSTWD, ELSTWD       )
               CALL M2BEGR ( TEMP,              BLSTWD, ELSTWD, A, B )

               CLSTWD = MIN ( ELSTWD, BLSTWD + 8 )
               VTEMPL =      A .NE. B
     .                .OR. (.NOT. M2KEYW        ( TEMP(BLSTWD:ELSTWD) )
     .                      .AND.'@calendar' .EQ. TEMP(BLSTWD:CLSTWD) )
     .

               IF ( VTEMPL ) THEN
C
C                 There is a variable length template, the keywords
C                 that might terminate this template are given
C                 in TERMS up to the first occurance of a '}'.
C
                  IF ( GMATCH .LT. MOST-1 ) THEN
                     I = LSTLTI ( BEGOFG, CARDI(INDXES), INDXES(1) ) + 1
                  ELSE
                     I = LSTLTI ( AFTERG, CARDI(INDXES), INDXES(1) ) + 1
                  END IF

                  J = 0

                  DO WHILE ( TERMS(I) .NE. '}' )

C
C                    Keep only those keywords that are not the initial
C                    keyword of this template.
C

                     IF ( INDXES(I) .NE. BS ) THEN
                        J          = J + 1
                        CALL M2TRIM ( TERMS(I), KEYWDS(J) )
                     END IF

                     I             = I + 1
                  END DO

                  CALL SCARDC ( J, KEYWDS )

               ELSE

                  CALL SCARDC ( 0, KEYWDS )

               END IF

C
C              Check the current template with M2MTCH.
C

               IF ( TEMP(BS:ES) .EQ. '@options' ) THEN

                  T1CODE = -1
                  TSCORE = -1

               ELSE

C
C                 Dump the temporary parse table.
C
                  CALL M2TCLR
                  CALL M2MTCH ( TEMP(BS:ES), 1,       KEYWDS,
     .                          STRING,      SBEG,    .FALSE., CUTOFF,
     .                          T1CODE,      TSCORE,  CAUSE           )

               END IF
C
C              If the attempt at a match succeeded ...
C
               IF ( T1CODE .EQ. 0 ) THEN

C
C                 Increment the number of group matches by 1.
C                 Increment the score for this template.
C                 Set the best score obtained thus far to zero
C                 in preparation for the next pass through the
C                 group.
C
                  GMATCH = GMATCH + 1
                  SCORE  = SCORE  + TSCORE
                  BSCORE = -1

C
C                 Move the temporary parse table to the keepers
C                 parse table.
C
                  CALL M2KEEP
C
C                 The current template should be taken off the viable
C                 list.
C
                  IF ( ES .LT. ENDOFG ) THEN
                     TEMP (BS:ES+2) = ' '
                  ELSE
                     CALL FNDPTK ( TEMP, ' ',  BS, A, B )

                     IF ( TEMP(A:B) .EQ. '|' ) THEN
                        TEMP (  A:ES ) = ' '
                     ELSE
                        TEMP ( BS:ES ) = ' '
                     END IF

                  END IF

C
C                 Reset ES to be the one before the beginning of
C                 the group template (BS will be set to ES + 1
C                 at the end of the group loop).
C
                  ES = BEGOFG - 1

C
C                 Adjust the possible terminating keyword set.
C                 (remove the initial keyword of the simple template
C                 just matched from the collection).
C
                  LOC    = BSRCHI ( BS, CARDI(INDXES), INDXES(1) )

                  CALL REMLAI ( 1, LOC, INDXES(1), CARDI(INDXES) )
                  CALL REMLAC ( 1, LOC, TERMS(1),  CARDC(TERMS)  )

                  CALL SCARDC ( CARDC(TERMS)  - 1, TERMS      )
                  CALL SCARDI ( CARDI(INDXES) - 1, INDXES     )

C
C                 Finally, if we have now exactly matched FEWEST-1,
C                 remove the '}' that has index equal to the index
C                 of the '}' that is the terminator of this group.
C
                  IF ( GMATCH .EQ. FEWEST - 1 ) THEN
                     LOC = BSRCHI ( ENDOFG+2, CARDI(INDXES), INDXES(1) )

                     IF ( LOC .NE. 0 ) THEN
                        CALL REMLAI ( 1, LOC, INDXES(1), CARDI(INDXES) )
                        CALL REMLAC ( 1, LOC, TERMS(1),  CARDC(TERMS)  )

                        CALL SCARDC ( CARDC(TERMS)  - 1, TERMS      )
                        CALL SCARDI ( CARDI(INDXES) - 1, INDXES     )
                     END IF
                  END IF

               ELSE

C
C                 Record the score if this is higher than a previous
C                 value.
C
                  IF ( TSCORE .GT. BSCORE ) THEN

                     BSCORE = TSCORE
                     BDIAGS = BS
                     EDIAGS = ES
                     BCODE  = T1CODE

                     CALL COPYC ( KEYWDS, SWORDS )

                  END IF

               END IF

C
C              Remove all introductory '@options' directives.
C
               OPTDIR = .TRUE.

               DO WHILE ( OPTDIR )

                  BO = NCPOS (        TEMP, ' ',    BEGOFG )
                  EO = MIN   ( UPTO ( TEMP, ' | ',  BEGOFG ),
     .                         UPTO ( TEMP, ' } ',  BEGOFG ) )

                  IF ( BO .LT. EO ) THEN

                     OPTDIR = TEMP(BO:EO) .EQ. '@options'

                     IF ( OPTDIR ) THEN
                        TEMP(BO:EO) = ' '
                        EO          = EO+2

                        IF ( TEMP(EO:EO) .EQ. '|' ) THEN
                           TEMP(EO:EO) = ' '
                        END IF
                     END IF

                  ELSE
                     OPTDIR = .FALSE.
                  END IF
               END DO
C
C              Should we stay in this group? Only if you can answer yes
C              to  all of the following:
C
C                  1.) Are more matches allowed for this group.
C
C                  2.) Is there another template in this group that
C                      hasn't been checked.
C
               IF ( GMATCH .GE. MOST ) THEN

                  GROUP = .FALSE.

               ELSE

C
C                 Make sure there is a viable simple template within
C                 this group.
C

                  BS = NCPOS( TEMP,  ' |',    ES + 1        )
                  ES = MIN  ( UPTO ( TEMP, ' | ', BS      ),
     .                        UPTO ( TEMP, ' } ', BS      )  )

                  IF (      ( BS          .EQ. 0      )
     .                 .OR. ( BS          .GE. ES     )
     .                 .OR. ( TEMP(BS:BS) .EQ. '}'    )
     .                 .OR. ( ES          .GT. ENDOFG ) ) THEN

                     GROUP = .FALSE.

                  END IF

               END IF

            END DO

C
C           When we leave the group, see if we had a sufficient number
C           of matches.  If we did, jump past the end of the group.
C           If we didn't, this is an error---head for home.
C
            OPTDIR = INDEX ( TEMP(BEGOFG:ENDOFG), ' @options ' ) .NE. 0

            IF (  .NOT. OPTDIR
     .            .AND. GMATCH .GE. FEWEST ) THEN

               TBEG = AFTERG

            ELSE IF ( OPTDIR .AND. ( GMATCH .GE. MOST  )  ) THEN

               IF ( REASON ) THEN

                  CALL CMPRSS ( ' ', 1, TEMP(BEGOFG:ENDOFG),
     .                                  TEMP(BEGOFG:ENDOFG)    )

                  B = BEGOFG - 1
                  E = INDEX ( TEMP(BEGOFG:ENDOFG), ' @options ' )
     .              + 1

                  CAUSE(1) = 'I had already matched the maximum '     //
     .                       'number of allowed simple templates in ' //
     .                       'a group without matching the  '         //
     .                       'following REQUIRED templates./cr/cr(3:3)'
                  CALL SUFFIX ( TEMP(B:E),        1, CAUSE(1) )
                  CALL SUFFIX ('} /cr/cr(-3:-3)', 1, CAUSE(1) )

                  M2CODE =  11000
                  MORE   = .FALSE.

               END IF

            ELSE IF ( OPTDIR .AND. ( GMATCH .GE. FEWEST ) ) THEN

               SCORE = SCORE + BSCORE

C
C              If diagnostics are requested then see what went wrong
C              with the best fitting simple template.
C
               IF ( REASON ) THEN

                  BS = BDIAGS
                  ES = EDIAGS

                  CALL M2MTCH ( TEMP(BS:ES), 1,       SWORDS,
     .                          STRING,      SBEG,    REASON, CUTOFF,
     .                          T1CODE,      TSCORE,  CAUSE           )

                  CAUSE(2) = CAUSE(1)

                  B        = BEGOFG - 1
                  E        = ENDOFG + 2

                  CALL CMPRSS ( ' ', 1, TEMP(B:E), SUBTMP )

                  IF (       INDEX( SUBTMP, ' | ' )
     .                 .EQ.  INDEX( SUBTMP, ' @options ' ) - 2 )
     .            THEN

                     CALL PREFIX ( '/cr/cr(-3:)',   1, CAUSE(2) )
                     CALL PREFIX ( SUBTMP,          1, CAUSE(2) )
                     CALL PREFIX ( 'Although I had matched a required'//
     .                             ' number of expressions in the '   //
     .                             'group below, I had not yet match' //
     .                             'ed the explicitely required '     //
     .                             'expression that appears prior to' //
     .                             ' the META/2 "@options" directive '//
     .                             'in the group shown here./cr(3:) ',
     .                              1, CAUSE(2)            )

                     K = POS( SUBTMP, ' | ', INDEX(SUBTMP,' @options '))

                     IF (     ( K                         .GT. 0 )
     .                  .AND. ( NCPOS (STRING, ' ', SBEG) .NE. 0 )) THEN

                        CALL SUFFIX ( '/cr/cr Of the remaining simple'//
     .                                ' templates '                   //
     .                                '(including the optional ones) '//
     .                                'the one that comes closest '   //
     .                                'to matching is: /cr/cr(3:) ',
     .                                 1, CAUSE(2)      )
                        CALL SUFFIX ( TEMP(BDIAGS:EDIAGS),
     .                                1, CAUSE(2)      )
                        CALL SUFFIX ( '/cr/cr(-3:)', 0, CAUSE(2)      )

                     END IF

                  ELSE

                     CALL PREFIX ( '/cr/cr(-3:)',     1, CAUSE(2) )
                     CALL PREFIX ( SUBTMP,            0, CAUSE(2) )
                     CALL PREFIX ( 'Although I had matched a required'//
     .                             ' number of expressions in the '   //
     .                             'group below, I had not yet match' //
     .                             'ed the explicitely required '     //
     .                             'expressions that appear prior to' //
     .                             ' the META/2 "@options" directive '//
     .                             'in the group shown here. '        //
     .                             './cr/cr(3:) ',   1, CAUSE(2) )

                     IF ( NCPOS (STRING, ' ', SBEG) .NE. 0 ) THEN

                        CALL SUFFIX ( '/cr/crOf the remaining simple' //
     .                                ' templates, '                  //
     .                                'the one that comes closest '   //
     .                                'to matching is: /cr/cr(3:) ',
     .                                                     1, CAUSE(2) )
                        CALL SUFFIX ( TEMP(BDIAGS:EDIAGS), 1, CAUSE(2) )
                        CALL SUFFIX ( '/cr/cr(-3:)',       0, CAUSE(2) )

                     END IF

                  END IF

               END IF

               M2CODE = BCODE
               MORE   = .FALSE.

            ELSE IF ( GMATCH .LT. FEWEST ) THEN

               SCORE = SCORE + BSCORE

C
C              If diagnostics are requested then see what went wrong
C              with the best fitting simple template.
C
               IF ( REASON ) THEN

                  BS = BDIAGS
                  ES = EDIAGS

                  CALL M2MTCH ( TEMP(BS:ES), 1,       SWORDS,
     .                          STRING,      SBEG,    REASON, CUTOFF,
     .                          T1CODE,      TSCORE,  CAUSE           )

                  CAUSE(2) = CAUSE(1)

                  B        = BEGOFG - 1
                  E        = ENDOFG + 2

                  CALL CMPRSS ( ' ', 1, TEMP(B:E), SUBTMP )

                  IF ( INDEX( SUBTMP, ' | ' ) .NE. 0 ) THEN

                     CALL PREFIX ( '''./cr/cr(-3:)',
     .                             1,         CAUSE (2)               )
                     CALL PREFIX ( TEMP ( BDIAGS:EDIAGS ),
     .                             0,         CAUSE (2)               )
                     CALL PREFIX ( 'I was trying to match part of '   //
     .                             'the input string with one of '    //
     .                             'the expressions listed here:'     //
     .                             '/cr/cr(3:) '                      //
     .                             SUBTMP(1:RTRIM(SUBTMP))           //
     .                             './cr/cr(-3:) The expression '    //
     .                             'that came '//
     .                             'closest was: /cr/cr(3:)''',
     .                             0,         CAUSE (2)               )
                  ELSE

                     CALL PREFIX ( '''./cr/cr(-3:)',
     .                             1,         CAUSE (2)                )
                     CALL PREFIX ( TEMP ( BDIAGS:EDIAGS ),
     .                             0,         CAUSE (2)                )
                     CALL PREFIX ( 'I was trying to match part of '   //
     .                             'the input string with the '       //
     .                             'expression: /cr/cr(3:) ''',
     .                              0,         CAUSE (2)              )

                  END IF

               END IF

               M2CODE = BCODE
               MORE   = .FALSE.

            END IF
C
         ELSE IF  ( SIMPLE ) THEN

            TEND   = MIN (  UPTO ( TEMP, ' @then', TBEG       ),
     .                      UPTO ( TEMP, '){ ',    TBEG       )
     .                   ) + 1

            CALL FNDPTK  (  TEMP,  ' ',  TEND, BLSTWD, ELSTWD )

            TEND = ELSTWD
C
C           See if the simple template ends with a variable template.
C           If it does, find out what the possible terminating words
C           are.
C
            A = 0
            B = 0

            CALL M2BEGR ( TEMP, BLSTWD, ELSTWD, A, B )

            CLSTWD = MIN ( ELSTWD, BLSTWD + 8 )
            VTEMPL =      A .NE. B
     .             .OR. (.NOT. M2KEYW        ( TEMP(BLSTWD:ELSTWD) )
     .                   .AND.'@calendar' .EQ. TEMP(BLSTWD:CLSTWD) )

            IF ( VTEMPL ) THEN

C
C              There is a variable length template, the keywords
C              that might terminate this template are given
C              in TERMS up to the first occurance of a '}'.
C
               I = LSTLTI( ELSTWD, CARDI(INDXES), INDXES(1) ) + 1
               J = 0

C
C              Just load keywords onto the list until we hit a '}'
C              (We are guarenteed that this will happen, because
C              we put a '}' on the end of the list at the beginning
C              of this routine.)
C
               DO WHILE ( TERMS(I) .NE. '}' )

                  J          = J + 1
                  CALL M2TRIM ( TERMS(I), KEYWDS(J) )
                  I          = I + 1

               END DO

               CALL SCARDC ( J , KEYWDS )

            ELSE

               CALL SCARDC ( 0,     KEYWDS )

            END IF

C
C           Check the current template with M2MTCH.
C
               CALL M2TCLR
               CALL M2MTCH ( TEMP(TBEG:TEND), 1,       KEYWDS,
     .                       STRING,          SBEG,    .FALSE., CUTOFF,
     .                       T1CODE,          TSCORE,  CAUSE           )

C
C           If the attempt at a match succeeded ...
C
            IF ( T1CODE .EQ. 0 ) THEN

               SCORE  = SCORE  + TSCORE
               TBEG   = TEND   + 1
               CALL     M2KEEP

            ELSE

               CALL M2MTCH ( TEMP(TBEG:TEND), 1,       KEYWDS,
     .                       STRING,          SBEG,    REASON, CUTOFF,
     .                       T1CODE,          TSCORE,  CAUSE           )

               SCORE  = SCORE + TSCORE
               M2CODE = T1CODE
               MORE   = .FALSE.

            END IF

         END IF

      END DO

C
C     If there were no THNWDS and there is stuff left in the string and
C     we haven't already noticed, we've got an error dude.
C
      IF (       ( CARDC(THNWDS) .EQ. 0                )
     .     .AND. ( SBEG          .LT. QLSTNB( STRING ) )
     .     .AND. ( M2CODE        .EQ. 0                ) ) THEN

C
C        Until we have evidence to justify looking for probable causes
C        of the current overage of input string, we assume that we
C        are not interested in offering conjectures about what the
C        problem is.  We'll just say there is extra stuff.
C
         REDIAG = .FALSE.

C
C        Now look for justification of fancier diagnostics.
C
C        Was the last thing we attempted to match part of a group
C        template?
C
         IF (       ( LAST   .EQ. 'GROUP' )
     .        .AND. ( GMATCH .LT.  MOST   ) ) THEN

C
C           We are going to see if one of the options of an ending group
C           template looks like it was the intention of the user.
C
            IF ( BCODE .LT. 100 ) THEN

C
C              We had a probable spelling error, set the flag to
C              diagnose the problem.
C
               REDIAG = .TRUE.

            ELSE

C
C              Look at what the score could have been for the
C              simple template that was the closest match.
C
               I      = 1
               J      = BDIAGS
               TSCORE = 0

               CALL FNDNWD ( TEMP, J, I, TMPJ )
               J = TMPJ

               DO WHILE ( ( I .NE. 0 ) .AND. ( I .LT. EDIAGS ) )

                  A = 1
                  B = 1

                  CALL M2BEGR (  TEMP, I, J, A, B )

                  IF ( M2KEYW( TEMP(I:J) ) ) THEN
                     TSCORE = TSCORE + 100
                  ELSE
                     TSCORE = TSCORE + A*15
                  END IF

                  CALL FNDNWD ( TEMP, J, I, TMPJ )
                  J = TMPJ

               END DO

C
C              If the score actually recorded made it at least a quarter
C              of the way, we will guess that this may have been the
C              root of the problem.
C
               REDIAG = BSCORE .GT. MAX( CUTOFF, TSCORE/4 )

            END IF
         END IF

C
C        If there was sufficient grounds to warrant second guessing,
C        run the best guess template through M2MTCH to get a diagnostic.
C
         IF ( REDIAG ) THEN

            IF ( REASON ) THEN

               BS = BDIAGS
               ES = EDIAGS

               CALL M2MTCH ( TEMP(BS:ES), 1,       KEYWDS,
     .                       STRING,      SBEG,    REASON, CUTOFF,
     .                       T1CODE,      TSCORE,  CAUSE           )

               CAUSE(2) = CAUSE(1)

               B = BEGOFG - 1
               E = ENDOFG + 2

               CALL CMPRSS ( ' ', 1, TEMP(B:E), SUBTMP )

               IF ( INDEX( SUBTMP, ' | ' ) .NE. 0 ) THEN

                  CALL PREFIX ( '''./cr/cr(-3:)',
     .                          1,         CAUSE(2)                 )
                  CALL PREFIX ( TEMP ( BDIAGS:EDIAGS ),
     .                          0,         CAUSE(2)                 )
                  CALL PREFIX ( 'Extra words appear in the input ' //
     .                          'string that are not part of a '   //
     .                          'valid expression. I think you '   //
     .                          'may have been trying to supply '  //
     .                          'one of the optional expressions ' //
     .                          'listed here:/cr/cr(3:) '          //
     .                          SUBTMP(1:RTRIM(SUBTMP))            //
     .                          '/cr/cr(-3:). '                    //
     .                          'The expression that came '        //
     .                          'closest was: /cr/cr(3:) ''',
     .                          0,         CAUSE(2)                 )
               ELSE

                  CALL PREFIX ( '''./cr/cr(-3:)',
     .                          1,         CAUSE(2)                 )
                  CALL PREFIX ( TEMP ( BDIAGS:EDIAGS ),
     .                          0,         CAUSE(2)                 )
                  CALL PREFIX ( 'Extra words appear in the input ' //
     .                          'string that are not part of a '   //
     .                          'valid expression. I think you '   //
     .                          'may have been trying to supply '  //
     .                          'the optional expression:/cr/cr(3:)''',
     .                           0,         CAUSE(2)                 )

               END IF

            END IF

C
C           Whatever error code we got back, add 10000 so that this
C           routine will have its stamp on it to indicate we are second
C           level guessing at what went wrong.
C
            M2CODE = 10000 + T1CODE

         ELSE

C
C           Sorry, we couldn't guess why there was extra stuff in the
C           command.  Maybe just happy fingers.  Anyway, just say there
C           was extra stuff and hit the road.
C
            IF ( REASON ) THEN
               CAUSE(1) = 'The input string contains extra words that'//
     .                    ' are not recognized as part of a valid '   //
     .                    'command.'

               CALL M2MARK ( STRING, SBEG, QLSTNB(STRING), CAUSE(1) )
            END IF

            M2CODE = 10200

         END IF

      END IF

      RETURN
      END

max_stars_repo_name: agforero/FTFramework

max_issues_repo_name: agforero/fortran-testing-framework

max_forks_repo_name: agforero/fortran-testing-framework