subroutine evaljo(pjo,kobs,kprt,louter)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    evaljo
!   prgmmr: tremolet
!
! abstract: Computes and prints Jo components
!
! program history log:
!   2007-03-01  tremolet
!   2009-01-15  todling  - quad precision for reproducibility
!   2009-08-14  lueken   - update documentation
!
!   input argument list:
!     kprt - print level
!     louter
!
!   output argument list:
!     kobs - Number of obs used in evaluating Jo
!     pjo  - Jo value
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
  use kinds, only: r_kind,i_kind,r_quad
  use obs_sensitivity, only: obsensCounts_set
  use gsi_obOperTypeManager, only: obOper_typeInfo
  use m_obsdiags   , only: obsdiags
  use m_obsdiagNode, only: obs_diag
  use gsi_4dvar, only: nobs_bins
  use constants, only: zero_quad
  use mpimod, only: ierror,mpi_comm_world,mpi_sum,mpi_integer,mype
  use jfunc, only: jiter
  use mpl_allreducemod, only: mpl_allreduce
  use mpeu_util, only: perr,die

  implicit none

! Declare passed variables
  real(r_quad)   ,intent(  out) :: pjo
  integer(i_kind),intent(  out) :: kobs
  integer(i_kind),intent(in   ) :: kprt
  logical        ,intent(in   ) :: louter

! Declare local variables
  character(len=*), parameter :: myname='evaljo'
  integer(i_kind) :: ii,jj,ij,ilen
  integer(i_kind) ::    iobs(size(obsdiags,1))
  real(r_quad)    :: zjo,zz
  real(r_kind)    :: zdep
  real(r_quad)    ::    zjo1(size(obsdiags,1))
  real(r_quad)    ::    zjo2(size(obsdiags,1),nobs_bins)
  real(r_quad)    ::  zprods(size(obsdiags,1)*nobs_bins)
  integer(i_kind) :: iobsgrp(size(obsdiags,1),nobs_bins)
  integer(i_kind) :: iobsglb(size(obsdiags,1),nobs_bins)
  type(obs_diag),pointer:: obsptr
  character(len=20):: cobstype_ii
  integer(i_kind) :: nobs_type
! ----------------------------------------------------------

zprods(:)=zero_quad
iobsgrp(:,:)=0
iobsglb(:,:)=0
nobs_type = size(obsdiags,1)

if(size(obsdiags,2)/=nobs_bins) then
  call perr(myname,'size(obsdiags,2)/=nobs_bins, size(obsdiags,2) =',size(obsdiags,2))
  call perr(myname,'                                    nobs_bins =',nobs_bins)
  call  die(myname)
endif

ij=0
do ii=1,nobs_bins
   do jj=1,nobs_type
      ij=ij+1

      !++ if(louter) then
      !++   zprods(ij) = obsLL(jj,ii)%NLDdotprod(jiter,nob=iobsgrp(jj,ii))
      !++ else
      !++   zprods(ij) = obsLL(jj,ii)%DELdotprod(jiter,nob=iobsgrp(jj,ii))
      !++ endif
      obsptr => obsdiags(jj,ii)%head
      do while (associated(obsptr))
         if (obsptr%luse.and.obsptr%muse(jiter)) then
            if (louter) then
               zdep=obsptr%nldepart(jiter)
            else
               zdep=obsptr%tldepart(jiter)-obsptr%nldepart(jiter)
            endif
            zprods(ij) = zprods(ij) + obsptr%wgtjo * zdep * zdep
            iobsgrp(jj,ii)=iobsgrp(jj,ii)+1
         endif
         obsptr => obsptr%next
      enddo

   enddo
enddo

! Sum Jo contributions
call mpl_allreduce(nobs_type*nobs_bins,qpvals=zprods)

! Sum number of observations
ilen=nobs_bins*nobs_type
call mpi_allreduce(iobsgrp,iobsglb,ilen, &
                 & mpi_integer,mpi_sum,mpi_comm_world,ierror)

! Gather Jo contributions

ij=0
do ii=1,nobs_bins
   do jj=1,nobs_type
      ij=ij+1
      zjo2(jj,ii)=zprods(ij)
   enddo
enddo

zjo1=zero_quad
iobs=0
DO ii=1,nobs_bins
   zjo1(:)=zjo1(:)+zjo2(:,ii)
   iobs(:)=iobs(:)+iobsglb(:,ii)
ENDDO

zjo=zero_quad
kobs=0
DO ii=1,nobs_type
   zjo=zjo+zjo1(ii)
   kobs=kobs+iobs(ii)
ENDDO

pjo=zjo

! Prints
IF (kprt>=2.and.mype==0) THEN
   if (louter) then
      write(6,*)'Begin Jo table outer loop'
   else
      write(6,*)'Begin Jo table inner loop'
   endif

   IF (kprt>=3.and.nobs_bins>1) THEN
      write(6,400)'Observation Type','Bin','Nobs','Jo','Jo/n'
      DO ii=1,nobs_type
         cobstype_ii=obOper_typeInfo(ii)
         DO jj=1,nobs_bins
            IF (iobsglb(ii,jj)>0) THEN
               zz=zjo2(ii,jj)/iobsglb(ii,jj)
               write(6,100)cobstype_ii,jj,iobsglb(ii,jj),real(zjo2(ii,jj),r_kind),real(zz,r_kind)
            ENDIF
         ENDDO
      ENDDO
   ENDIF

   write(6,400)'Observation Type',' ','Nobs','Jo','Jo/n'
   DO ii=1,nobs_type
      cobstype_ii=obOper_typeInfo(ii)
      IF (iobs(ii)>0) THEN
         zz=zjo1(ii)/iobs(ii)
         write(6,200)cobstype_ii,iobs(ii),real(zjo1(ii),r_kind),real(zz,r_kind)
      ENDIF
   ENDDO

   IF (kobs>0) THEN
      zz=zjo/kobs
   ELSE
      zz=-999.999_r_quad
   ENDIF
   write(6,400)'  ',' ','Nobs','Jo','Jo/n'
   write(6,300)"Jo Global",kobs,real(zjo,r_kind),real(zz,r_kind)

   if (louter) then
      write(6,*)'End Jo table outer loop'
   else
      write(6,*)'End Jo table inner loop'
   endif
ENDIF

call obsensCounts_set(iobsglb(:,:))

100 format(a20,2x,i3,2x,i8,2x,es24.16,2x,f10.3)
200 format(a20,2x,3x,2x,i8,2x,es24.16,2x,f10.3)
300 format(a20,2x,3x,2x,i8,2x,es24.16,2x,f10.3)
400 format(a20,2x,a3,2x,a8,2x,a24,4x,a8)

! ----------------------------------------------------------
return
end subroutine evaljo


! RUN: %S/test_folding.sh %s %t %flang_fc1
! REQUIRES: shell
! Test implementations of IEEE inquiry functions
module m
  use ieee_arithmetic
  logical, parameter :: test_ieee_support_datatype = ieee_support_datatype() &
    .and. ieee_support_datatype(1.0_2) &
    .and. ieee_support_datatype(1.0_3) &
    .and. ieee_support_datatype(1.0_4) &
    .and. ieee_support_datatype(1.0_8) &
    .and. ieee_support_datatype(1.0_10) &
    .and. ieee_support_datatype(1.0_16)
  logical, parameter :: test_ieee_support_denormal = ieee_support_denormal() &
    .and. ieee_support_denormal(1.0_2) &
    .and. ieee_support_denormal(1.0_3) &
    .and. ieee_support_denormal(1.0_4) &
    .and. ieee_support_denormal(1.0_8) &
    .and. ieee_support_denormal(1.0_10) &
    .and. ieee_support_denormal(1.0_16)
  logical, parameter :: test_ieee_support_divide = ieee_support_divide() &
    .and. ieee_support_divide(1.0_2) &
    .and. ieee_support_divide(1.0_3) &
    .and. ieee_support_divide(1.0_4) &
    .and. ieee_support_divide(1.0_8) &
    .and. ieee_support_divide(1.0_10) &
    .and. ieee_support_divide(1.0_16)
  logical, parameter :: test_ieee_support_inf = ieee_support_inf() &
    .and. ieee_support_inf(1.0_2) &
    .and. ieee_support_inf(1.0_3) &
    .and. ieee_support_inf(1.0_4) &
    .and. ieee_support_inf(1.0_8) &
    .and. ieee_support_inf(1.0_10) &
    .and. ieee_support_inf(1.0_16)
  logical, parameter :: test_ieee_support_io = ieee_support_io() &
    .and. ieee_support_io(1.0_2) &
    .and. ieee_support_io(1.0_3) &
    .and. ieee_support_io(1.0_4) &
    .and. ieee_support_io(1.0_8) &
    .and. ieee_support_io(1.0_10) &
    .and. ieee_support_io(1.0_16)
  logical, parameter :: test_ieee_support_nan = ieee_support_nan() &
    .and. ieee_support_nan(1.0_2) &
    .and. ieee_support_nan(1.0_3) &
    .and. ieee_support_nan(1.0_4) &
    .and. ieee_support_nan(1.0_8) &
    .and. ieee_support_nan(1.0_10) &
    .and. ieee_support_nan(1.0_16)
  logical, parameter :: test_ieee_support_sqrt = ieee_support_sqrt() &
    .and. ieee_support_sqrt(1.0_2) &
    .and. ieee_support_sqrt(1.0_3) &
    .and. ieee_support_sqrt(1.0_4) &
    .and. ieee_support_sqrt(1.0_8) &
    .and. ieee_support_sqrt(1.0_10) &
    .and. ieee_support_sqrt(1.0_16)
  logical, parameter :: test_ieee_support_standard = ieee_support_standard() &
    .and. ieee_support_standard(1.0_2) &
    .and. ieee_support_standard(1.0_3) &
    .and. ieee_support_standard(1.0_4) &
    .and. ieee_support_standard(1.0_8) &
    .and. ieee_support_standard(1.0_10) &
    .and. ieee_support_standard(1.0_16)
  logical, parameter :: test_ieee_support_subnormal = ieee_support_subnormal() &
    .and. ieee_support_subnormal(1.0_2) &
    .and. ieee_support_subnormal(1.0_3) &
    .and. ieee_support_subnormal(1.0_4) &
    .and. ieee_support_subnormal(1.0_8) &
    .and. ieee_support_subnormal(1.0_10) &
    .and. ieee_support_subnormal(1.0_16)
  logical, parameter :: test_ieee_support_underflow_control = ieee_support_underflow_control() &
    .and. ieee_support_underflow_control(1.0_2) &
    .and. ieee_support_underflow_control(1.0_3) &
    .and. ieee_support_underflow_control(1.0_4) &
    .and. ieee_support_underflow_control(1.0_8) &
    .and. ieee_support_underflow_control(1.0_10) &
    .and. ieee_support_underflow_control(1.0_16)
end module


text:
************************************************************************
* Read parameters for linear solver of CC2D
*
* This routine reads the parameters for the linear solver used
* in the nonlinear CC2D-iteration from a given file and stores
* them in the corresponding COMMON blockdiscretization.
*
* In:
*   MDATA  - Unit number to use for reading process
*   MSHOW  - Level of output in the initialization phase
*   CFNAME - Name of the file
************************************************************************

      SUBROUTINE RDLSCC (MDATA,MSHOW,CFNAME)

      IMPLICIT NONE

      INCLUDE 'cout.inc'
      INCLUDE 'cfileout.inc'
      INCLUDE 'cerr.inc'

      INCLUDE 'clinsol_cc2d.inc'

C     parameters

      CHARACTER CFNAME*(*)
      INTEGER MSHOW,MDATA

C     local variables

      INTEGER I,IFMTS
      CHARACTER CSTR*(255)

C     Open DAT file

      IFMTS = 1
      CALL OF0 (MDATA,CFNAME,IFMTS)

C     Ignore the first 6 lines

      DO I=1,6
        READ (MDATA,*)
      END DO

C     Check version number

      READ (MDATA,*) I
      IF (I.NE.100) THEN
        WRITE (*,'(A)') 'Error in reading linear-solver parameters'
        WRITE (*,'(A)') 'Version number incorrect'
        STOP
      END IF

      WRITE (CSTR,'(A)') ' Linear solver parameters'
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)
      WRITE (CSTR,'(A)') '--------------------------'
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

C     Ignore separator

      READ (MDATA,*)

C     Type of linear solver:

      READ (MDATA,*) ILINSL
      WRITE (CSTR,1000)
     *      'Type of linear solver         : ILINSL = ', ILINSL
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

C     Minimum/Maximum number of iterations

      READ (MDATA,*) ILMIN
      READ (MDATA,*) ILMAX

      ILMIN=ABS(ILMIN)
      ILMAX=ABS(ILMAX)
      IF (ILMAX.LT.ILMIN) ILMAX=ILMIN

      WRITE (CSTR,1000)
     *      'Min. # of steps in lin. sol.  : ILMIN  = ', ILMIN
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

      WRITE (CSTR,1000)
     *      'Max. # of steps in lin. sol.  : ILMAX  = ', ILMAX
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

C     Number of preconditioning steps if MG is used as preconditioner

      READ (MDATA,*) IPCMG

      WRITE (CSTR,1000)
     *      '#precond. steps of MG precond.: IPCMG  = ', IPCMG
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

C     Error bounds, stopping criteria

      READ (MDATA,*) DMPMG
      WRITE (CSTR,1001)
     *      'Damping of residuals          : DMPMG  = ', DMPMG
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

      READ (MDATA,*) EPSMG
      WRITE (CSTR,1001)
     *      'Limit of residuals            : EPSMG  = ', EPSMG
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

C     General damping parameter

      READ (MDATA,*) OMGLIN
      WRITE (CSTR,1001)
     *      'Damping parameter for solver  : OMGLIN = ', OMGLIN
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

C     Separator

      READ (MDATA,*)
      WRITE (MTERM,9001)

C     Multigrid cycle

      READ (MDATA,*) ICYCLE
      ICYCLE=ABS(ICYCLE)
      WRITE (CSTR,1000)
     *      'Type of MG cycle              : ICYCLE = ', ICYCLE
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

C     Minimum/Maximum correction parameter in the coarse grid correction

      READ (MDATA,*) AMINMG
      WRITE (CSTR,1001)
     *      'Lower limit optimal MG-ALPHA  : AMINMG = ', AMINMG
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

      READ (MDATA,*) AMAXMG
      WRITE (CSTR,1001)
     *      'Upper limit optimal MG-ALPHA  : AMAXMG = ', AMAXMG
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

C     Separator

      READ (MDATA,*)
      WRITE (MTERM,9001)

C     Parameters for prolongation/restriction/creation of coarse grid
C     matrices

      READ (MDATA,*) IINT
      IF ((ABS(IINT).LT.1).OR.(ABS(IINT).GT.4)) IINT=2
      WRITE (CSTR,1000)
     *      'Type of interpolation         : IINT   = ', IINT
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

      READ (MDATA,*) IAVPR
      IF ((IAVPR.LT.0)) IAVPR=3
      WRITE (CSTR,1000)
     *      'Type of averaging in pr/rest  : IAVPR  = ', IAVPR
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

      READ (MDATA,*) DPREP
      WRITE (CSTR,1001)
     *      'Threshold-par. ext. prol/rest.: DPREP  = ', DPREP
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

      READ (MDATA,*) IAPR
      IF ((IAVPR.LT.0)) IAPR=3
      WRITE (CSTR,1000)
     *      'Type of adaptive prol./rest.  : IAPR   = ', IAPR
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

C     Separator

      READ (MDATA,*)
      WRITE (MTERM,9001)

C     Parameters for smoother

      READ (MDATA,*) ISM
      WRITE (CSTR,1000)
     *      'Type of smoother              : ISM    = ', ISM
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

      READ (MDATA,*) NSM
      NSM=ABS(NSM)
      WRITE (CSTR,1000)
     *      'Number of smoothing steps     : NSM    = ', NSM
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

      READ (MDATA,*) RLXSM
      WRITE (CSTR,1001)
     *      'Relaxation for the smoother   : RLXSM  = ', RLXSM
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

      READ (MDATA,*) NSMFAC
      IF (NSMFAC.LT.1) NSMFAC=1
      WRITE (CSTR,1000)
     *      'Factor sm. steps on coarser lv: NSMFAC = ', NSMFAC
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

C     Separator

      READ (MDATA,*)
      WRITE (MTERM,9001)

C     Coarse grid solver

      READ (MDATA,*) ISL
      WRITE (CSTR,1000)
     *      'Type of coarse grid solver    : ISL    = ', ISL
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

      READ (MDATA,*) NSL
      NSL=ABS(NSL)
      WRITE (CSTR,1000)
     *      'Max. # of steps in coarse-g.s.: NSL    = ', NSL
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

      READ (MDATA,*) RLXSL
      WRITE (CSTR,1001)
     *      'Relaxation for the c.g.-solver: RLXSL  = ', RLXSL
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

      READ (MDATA,*) DMPSL
      WRITE (CSTR,1001)
     *      'Damping of residuals in c.g.-s: DMPSL  = ', DMPSL
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

      READ (MDATA,*) EPSSL
      WRITE (CSTR,1001)
     *      'Limit of residuals in c.g.-s. : EPSSL  = ', EPSSL
      CALL CNOUTS (MSHOW,MTERM,MFILE,.TRUE.,CSTR)

C     That's it.

      WRITE (MTERM,*)

      CLOSE (MDATA)

1000  FORMAT (A,I4)
1001  FORMAT (A,E16.8)
1002  FORMAT (A,2I4)
1003  FORMAT (A,A)

9000  FORMAT(79('-'))
9001  FORMAT(60('-'))

      END

ext: f

max_stars_repo_licenses: Intel Unlicense

max_issues_repo_licenses: Intel Unlicense

max_forks_repo_licenses: Intel Unlicense


text:
cdis
cdis    Open Source License/Disclaimer, Forecast Systems Laboratory
cdis    NOAA/OAR/FSL, 325 Broadway Boulder, CO 80305
cdis
cdis    This software is distributed under the Open Source Definition,
cdis    which may be found at http://www.opensource.org/osd.html.
cdis
cdis    In particular, redistribution and use in source and binary forms,
cdis    with or without modification, are permitted provided that the
cdis    following conditions are met:
cdis
cdis    - Redistributions of source code must retain this notice, this
cdis    list of conditions and the following disclaimer.
cdis
cdis    - Redistributions in binary form must provide access to this
cdis    notice, this list of conditions and the following disclaimer, and
cdis    the underlying source code.
cdis
cdis    - All modifications to this software must be clearly documented,
cdis    and are solely the responsibility of the agent making the
cdis    modifications.
cdis
cdis    - If significant modifications or enhancements are made to this
cdis    software, the FSL Software Policy Manager
cdis    (softwaremgr@fsl.noaa.gov) should be notified.
cdis
cdis    THIS SOFTWARE AND ITS DOCUMENTATION ARE IN THE PUBLIC DOMAIN
cdis    AND ARE FURNISHED "AS IS."  THE AUTHORS, THE UNITED STATES
cdis    GOVERNMENT, ITS INSTRUMENTALITIES, OFFICERS, EMPLOYEES, AND
cdis    AGENTS MAKE NO WARRANTY, EXPRESS OR IMPLIED, AS TO THE USEFULNESS
cdis    OF THE SOFTWARE AND DOCUMENTATION FOR ANY PURPOSE.  THEY ASSUME
cdis    NO RESPONSIBILITY (1) FOR THE USE OF THE SOFTWARE AND
cdis    DOCUMENTATION; OR (2) TO PROVIDE TECHNICAL SUPPORT TO USERS.
cdis
cdis cdis
cdis
cdis
cdis
cdis
cdis
cdis
cdis
cdis
cdis
      subroutine moment_b(data,n,ave,adev,sdev,var,skew,curt,istatus)

c alternative moment program adapted from numerical recipies not to comflict
c with the other routine modifed and installed by Jim Edwards (moment.f)
c found under the satellite library area.

      integer n
      real adev,ave,curt,sdev,skew,var,data(n)
      integer j, istatus
      real p,s,ep
      istatus = 0 ! bad
      if(n.le.1) then
         write (6,*) 'must be at least 2 in moment comp'
         return
      endif
      s=0.
      do 11 j=1,n
        s=s+data(j)
11    continue
      ave=s/n
      adev=0.
      var=0.
      skew=0.
      curt=0.
      ep=0.
      do 12 j=1,n
        s=data(j)-ave
        ep=ep+s
        adev=adev+abs(s)
        p=s*s
        var=var+p
        p=p*s
        skew=skew+p
        p=p*s
        curt=curt+p
12    continue
      adev=adev/n
      var=(var-ep**2/n)/(n-1)
      if(var.lt.0.) then
         write(6,*) 'negative VAR detected, taking absolute value'
         var = abs(var)
      endif
      sdev=sqrt(var)
      if(var.gt.1.e-10) then
        skew=skew/(n*sdev**3)
        curt=curt/(n*var**2)-3.
      else
        skew = 0.0
        curt = 0.0
      write (6,*) 'Skew and Curt returned as zero, variance is small'
        return
      endif
      istatus = 1 !good
      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


text:
!!# COMMAND CARD SWITCHBOARD <<CCS_Materials>>
MODULE CCS_Materials

!!## PURPOSE
!! The switchboard for <Materials> (<MAT>) command
!! cards.

!!## FORTRAN STANDARD MODULES
USE ISO_varying_string !!((03-A-ISO_varying_string.f90))

!!## EXTERNAL KINDS
USE KND_XSExpansion,ONLY: KIND_Mac !!((02-A-KND_XSExpansion.f90))

!!## EXTERNAL PROCEDURES
USE SUB_Pause !!((04-B-SUB_Pause.f90))
USE SUB_Reallocate !!((04-B-SUB_Reallocate.f90))
USE SUB_Find !!((05-B-SUB_Find.f90))
USE FUN_INDEXa !!((08-B-FUN_INDEXa.f90))
USE FUN_ptr_INDICESa !!((09-B-FUN_ptr_INDICESa.f90))
USE FUN_LEN_TRIMa !!((03-A-FUN_LEN_TRIMa.f90))
USE FUN_STR !!((05-B-FUN_STR.f90))
USE FUN_VSTR !!((05-B-FUN_VSTR.f90))
USE FUN_ERROR !!(())

!!## GLOBAL USER MODULES
!! * simple pointer list
!! * feeback object user module
USE USR_SimpleList !!((09-B-USR_SimpleList.f90))
USE USR_fdbk !!((08-C-USR_fdbk.f90))
!USE USR_Source                                             !!((35-B-USR_Source.f90))

!!## GLOBAL LIBRARIES
USE LIB_Prompts !!((06-B-LIB_Prompts.f90))

!!## GLOBAL TOOLBOXES
!! * input/output toolbox
USE TBX_SIO !!((10-A-TBX_SIO.f90))
USE TBX_Mesh !!((15-B-TBX_Mesh.f90))

!!## GLOBAL VARIABLES
USE VAR_Materials    ,ONLY: TYPE_MaterialFill,Reallocate,& !!((48-B-VAR_Materials.f90))
                            LABEL_Materials,l_,MaterialFill
USE VAR_Source !!((47-B-VAR_Source.f90))
USE VAR_XSMonkey !!((47-B-VAR_XSMonkey.f90))
USE VAR_Mesh        ,ONLY: Mesh !!((46-B-VAR_Mesh.f90))
USE VAR_EnergyGroups,ONLY: NG !!((47-B-VAR_EnergyGroups.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## PRECALCULATED COMMAND HASHES
INTEGER,PARAMETER :: assoc_   = 0000018919
INTEGER,PARAMETER :: assoc0_  = 0000037634
INTEGER,PARAMETER :: init_    = 0000009704
INTEGER,PARAMETER :: macf0_   = 0000017396
INTEGER,PARAMETER :: macnu0_  = 0000034172
INTEGER,PARAMETER :: macs0_   = 0000018068
INTEGER,PARAMETER :: mact0_   = 0000018116
INTEGER,PARAMETER :: polygon_ = 0000092670

!!## PUBLIC ACCESS LIST
PUBLIC :: SWITCHBOARD_Materials

!!## MODULE PROCEDURES
CONTAINS

!!### SUBROUTINE <<SWITCHBOARD_Materials>>
SUBROUTINE SWITCHBOARD_Materials( sio , FdBk )

!!#### PURPOSE
!! The command DataBaSe for the Materials package.

!!#### REQUIRED INPUT/OUTPUT
!! * input/output object <sio>
TYPE(TYPE_sio),POINTER :: sio

!!#### OPTIONAL INPUT/OUTPUT
!! * feedback object <FdBk>
TYPE(TYPE_FdBk),OPTIONAL,INTENT(INOUT) :: FdBk

INTEGER :: j

!!--begin--
!pick routine to execute which loads some data
SELECTCASE(sio%HASH(2))

 CASE(init_)   ; CALL MATinit  ( sio , LABEL_materials , FdBk )

 CASE(assoc0_) ; CALL MATassoc0( sio , l_    , Mesh%CellLabels , LABEL_materials , FdBk )

 CASE(assoc_)  ; CALL MATassoc ( sio , l_    , Mesh%CellLabels , LABEL_materials , FdBk )

 CASE(mact0_)  ; CALL MATmac0  ( sio , MacT  , j , NG , LABEL_materials , FdBk )

 CASE(macs0_)  ; CALL MATmac0  ( sio , MacS  , j , NG , LABEL_materials , FdBk )

 CASE(macnu0_) ; CALL MATmac0  ( sio , MacNu , j , NG , LABEL_materials , FdBk )

 CASE(macf0_)  ; CALL MATmac0  ( sio , MacF  , j , NG , LABEL_materials , FdBk )

 CASE(polygon_); CALL MATpolygon( sio , LABEL_materials , MaterialFill , NUM_Dimensions(Mesh) , FdBk )

 CASE DEFAULT ; WRITE(*,"(a)")WarningPrompt//"MAT (material) command: \"//TRIM(STR(sio%cmd))&
                      //", NOT RECOGNIZED ON LINE=",TRIM(STR(sio%LINE_NUM))//" of FILE="//TRIM(STR(sio%FILE))
ENDSELECT

!!--end--
ENDSUBROUTINE

!!### SUBROUTINE <<MATinit>>
SUBROUTINE MATinit( sio , LABEL_materials , FDBK )

!!#### PURPOSE
!! Initializes a material.

!!#### REQUIRED INPUT/OUTPUT
!! * input/output object <sio>
!! * list of material labels <LABEL_materials>
TYPE(TYPE_sio),POINTER :: sio
CHARACTER(*),POINTER :: LABEL_materials(:)

!!#### OPTIONAL INPUT/OUTPUT
!! * feedback object <FDBK>
TYPE(TYPE_FDBK),OPTIONAL,INTENT(INOUT) :: FDBK

!!#### LOCAL VARIABLES
CHARACTER(LEN(LABEL_materials)) :: string
!!--begin--
IF( Writing(sio) )THEN
 string = LABEL_materials(LEN_TRIMa(LABEL_materials))
 !take the material away from the list of material names
 CALL REMOVE_FROM_LIST( LABEL_materials , string )
ENDIF

!get the material name
CALL BEGIN_ARGUMENTS( sio , (/"material-label"/) )
CALL ARGUMENT( sio , string , FdBk )
CALL END_ARGUMENTS( sio , FdBk )

IF( Reading(sio) )THEN
 !add the material name to the list of material names
 CALL ADD_TO_LIST( LABEL_materials , string )
ENDIF

!!--end--
ENDSUBROUTINE

SUBROUTINE MATmac0( sio , Mac , j , NG , LABEL_materials , FDBK )
!!#### PURPOSE
!! Reads in a simple cross section for a material.

!!#### REQUIRED INPUT/OUTPUT
!! * input/output object <sio>
!! * index just inputted, or index to output <j>
!! * macroscopic cross section <Mac>
!! * list of material labels <LABEL_materials>
!! * number of energy groups <NG>
TYPE(TYPE_sio) ,POINTER    :: sio
INTEGER,INTENT(INOUT)    :: j
REAL(KIND_Mac),POINTER    :: Mac(:,:)
CHARACTER(*),INTENT(IN)  :: LABEL_materials(:)
INTEGER      ,INTENT(IN) :: NG

!!#### OPTIONAL INPUT/OUTPUT
!! * feedback object <FDBK>
TYPE(TYPE_FDBK),OPTIONAL,INTENT(INOUT) :: FDBK

!!--begin--
IF( Reading(sio) )THEN
 IF( .NOT.ASSOCIATED(Mac) )THEN
  ALLOCATE( Mac(1:NG,1:SIZE(LABEL_materials)) )
  Mac = ERROR(1._KIND_Mac)
 ELSE
  CALL REALLOCATE( Mac , dn=(/0,SIZE(LABEL_materials)-SIZE(Mac,2)/) , &
    fill = ERROR(1._KIND_Mac) )
 ENDIF
ENDIF

CALL BEGIN_ARGUMENTS(sio,(/"material-label"/),FdBk)
CALL ARGUMENT( sio , j , FdBk , Keys=LABEL_materials )
CALL END_ARGUMENTS( sio , FdBk )
CALL DATABLOCK( sio , Mac(:,j) , FDBK )

IF( Writing(sio) )THEN
 IF( SIZE(Mac,2)==1 )THEN
  DEALLOCATE( Mac )
  NULLIFY( Mac )
 ELSE
  CALL REALLOCATE( Mac , dn=(/0,-1/) )
 ENDIF
ENDIF

!!--end--
ENDSUBROUTINE

SUBROUTINE MATassoc0( sio , l_ , LABEL_cells , LABEL_materials , FDBK )
!!#### PURPOSE
!! Simple association of a cell with a material.

!!#### MODULES
USE FUN_INDEXa !!((08-B-FUN_INDEXa.f90))
USE SUB_Reallocate !!((04-B-SUB_Reallocate.f90))
USE FUN_SIZEa !!((06-B-FUN_SIZEa.f90))

!!#### REQUIRED INPUT
!! * cell table
!! * material table
CHARACTER(*),POINTER :: LABEL_materials(:)
CHARACTER(*),POINTER :: LABEL_cells(:)

!!#### REQUIRED INPUT/OUTPUT
!! * input/output object <sio>
!! * mapping of cell index to material index (cross sections are defined for materials)
TYPE(TYPE_sio),POINTER :: sio
INTEGER     ,POINTER :: l_(:)

!!#### OPTIONAL INPUT/OUTPUT
!! * feedback object <FDBK>
TYPE(TYPE_FDBK),OPTIONAL,INTENT(INOUT) :: FDBK

!!#### LOCAL VARIABLES
INTEGER :: i,l,Nc,Nm
!!--begin--
Nc=NUM_Cells(Mesh)
Nm=SIZEa(LABEL_Materials)

!get the cell label
CALL BEGIN_ARGUMENTS(sio,(/"cell-label    ",&
                          "material-label"/),FdBk)
CALL ARGUMENT( sio , i , FdBk , Keys=LABEL_cells(1:Nc)  )
CALL ARGUMENT( sio , l , FdBk , Keys=LABEL_materials(1:Nm) )
CALL END_ARGUMENTS( sio , FdBk )

IF( Reading(sio) )THEN
 !(re)allocate, if necessary
 IF( .NOT.ASSOCIATED(l_) )THEN
  ALLOCATE( l_(1:SIZE(LABEL_cells)) )
  l_ = 0
 ELSEIF( i>SIZE(l_) )THEN
  CALL REALLOCATE( l_ , 3 , Fill=INT(0,KIND(l_)) )
 ENDIF

 !set the mapping
 l_(i) = l
ENDIF

!!--end--
ENDSUBROUTINE

SUBROUTINE MATassoc( sio , l_ , LABEL_cells , LABEL_materials , FDBK )
!!#### PURPOSE
!! Association of a cell with a material
!! with a wild-card matching search.

!!#### MODULES
USE FUN_INDEX2 !!((04-B-FUN_INDEX2.f90))
USE SUB_Reallocate !!((04-B-SUB_Reallocate.f90))
USE FUN_SIZEa !!((06-B-FUN_SIZEa.f90))

!!#### REQUIRED INPUT
!! * cell table
!! * material table
CHARACTER(*),POINTER :: LABEL_materials(:)
CHARACTER(*),POINTER :: LABEL_cells(:)

!!#### REQUIRED INPUT/OUTPUT
!! * input/output object <sio>
!! * mapping of cell index to material index (cross sections are defined for materials)
TYPE(TYPE_sio),POINTER :: sio
INTEGER     ,POINTER :: l_(:)

!!#### OPTIONAL INPUT/OUTPUT
!! * feedback object <FDBK>
TYPE(TYPE_FDBK),OPTIONAL,INTENT(INOUT) :: FDBK

!!#### LOCAL VARIABLES
CHARACTER(LEN(LABEL_cells))     :: cell_label
INTEGER :: i,l,n,Nc,Nm

INTEGER,POINTER :: ilist(:)

!!--begin--

Nc=NUM_Cells(Mesh)
Nm=SIZEa(LABEL_Materials)

!get the cell label
CALL BEGIN_ARGUMENTS(sio,(/"cell-label    ",&
                           "material-label"/),FdBk)
CALL ARGUMENT( sio , cell_label , FdBk )
CALL ARGUMENT( sio , l , FdBk , KEYS=LABEL_Materials(1:Nm) )
CALL END_ARGUMENTS( sio , FdBk )

IF( Reading(sio) )THEN

 !allocate, if necessary
 IF( .NOT.ASSOCIATED(l_) )THEN
  ALLOCATE( l_(1:Nc) )
  l_ = 0

 !reallocate if necessary
 ELSE IF( Nc>SIZE(l_) )THEN
  CALL REALLOCATE( l_ , Nc-SIZE(l_) , Fill=INT(0,KIND(l_)) )
 END IF

 !find with wildcard "*"
 NULLIFY( ilist )
 ilist => ptr_INDICESa( LABEL_Cells(1:Nc) , Cell_label , CASESEN=.FALSE. , WILDCARD="*")

 !set material numbers for those cells
 IF( ASSOCIATED(ilist) )THEN
  DO n=1,SIZE(ilist)
   i = ilist(n)
   l_(i) = l
  END DO
  DEALLOCATE(ilist)

 !print warning message if no cell label matches criteria
 ELSE
  CALL UPDATE(fdbk_warning,fdbk,s="The cell label ("//TRIM(cell_label)//") does &
     &not exist.  The material ("//TRIM(LABEL_materials(l))//") cannot be associated with &
         &any cells.")
 END IF

END IF

!!--end--
END SUBROUTINE

SUBROUTINE MATpolygon( sio , LABEL_materials , MaterialFill , ndimensions , FDBK )
!!#### PURPOSE
!! Defines a polygon of a particular material to fill the mesh with.

!!#### REQUIRED INPUT/OUTPUT
!! * input/output object <sio>
!! * list of material labels <LABEL_materials>
TYPE(TYPE_sio)           ,POINTER :: sio
CHARACTER(*)            ,POINTER :: LABEL_materials(:)
TYPE(TYPE_MaterialFill)  ,POINTER :: MaterialFill(:)

!!#### REQUIRED INPUT
INTEGER,INTENT(IN) :: Ndimensions

!!#### OPTIONAL INPUT/OUTPUT
!! * feedback object <FDBK>
TYPE(TYPE_FDBK),OPTIONAL,INTENT(INOUT) :: FDBK

!!#### LOCAL VARIABLES
CHARACTER(LEN(LABEL_materials)) :: string
INTEGER :: n

!!--begin--
!if writing
IF( Writing(sio) )THEN

 !set label string
 string = LABEL_Materials( MaterialFill(SIZE(MaterialFill)) % l )

 !take the material away
 CALL Reallocate( MaterialFill , -1 )

!if reading
ELSE IF( Reading(sio) )THEN

 !reallocate
 CALL Reallocate( MaterialFill , 1 )

END IF

!A. ARGUMENTS: read/write the material label, number of points
CALL BEGIN_ARGUMENTS( sio , (/"material-label   ",&
                              "num-points       "/) , FdBk )
CALL ARGUMENT( sio , string , FdBk )
CALL ARGUMENT( sio , n , FdBk )
CALL END_ARGUMENTS( sio , FdBk )

!B. DATABLOCK: read/write the coefficients of the polygon
!! (just points of the polygon)
CALL DATABLOCK( sio , (/1,Ndimensions*n/) , MaterialFill(SIZE(MaterialFill))%coeff , FdBk )

IF( Reading(sio) )THEN
 !determine material fill material number
 MaterialFill(SIZE(MaterialFill))%l = INDEXa( LABEL_materials , TRIM(string) , CASESEN=.FALSE. )
END IF

!!--end--
END SUBROUTINE

END MODULE

max_stars_repo_name: wawiesel/tapack

max_issues_repo_name: wawiesel/tapack

max_forks_repo_name: wawiesel/tapack


text:
MODULE ObjectFunctions

  IMPLICIT NONE

  LOGICAL      :: optAlpha     = .TRUE.
  LOGICAL      :: optCoupling  = .TRUE.
  CHARACTER(8) :: couplingType = "CONSTANT"

  CONTAINS

  REAL(8) FUNCTION objectFunction(variables)

    ! #DES: This is the part that changes per-application. I am massively cheating by
    !       just importing eveything here for now.

    USE Input, ONLY : dGTS, dGPS, mask, Nbins, minPop
    USE Data, ONLY : energyGap, groundStateEnergy, mappingEnergies, RecomputeDependentData
    USE Analysis, ONLY : FepUsFreeEnergies
    USE EVBParameters, ONLY : DelinearizeParameters
    USE FreeEnergy, ONLY : FepUS, ScanFepUS, Histogram, computeFEPProfile

    IMPLICIT NONE

    REAL(8), INTENT(IN) :: variables(:)

    INTEGER :: binPopulations(Nbins,SIZE(energyGap,1)), binIndices(SIZE(energyGap,1),SIZE(energyGap,2))
    REAL(8) :: binMidpoints(Nbins)
    REAL(8) :: alpha(2), A(2,2), mu(2,2), eta(2,2)
    REAL(8) :: relative(3), binGg(Nbins)
    REAL(8) :: G_FEP(SIZE(energyGap,1))
    LOGICAL :: printBin(Nbins)

    ! For EVB-parameterisation, the variables are alpha and the parameters of the off-diagonals
    ! and the object function must depend on the FEP/US free energy changes

    CALL DelinearizeParameters(variables(:),alpha(:),A(:,:),mu(:,:),eta(:,:),optAlpha,optCoupling,couplingType)

    CALL RecomputeDependentData(alpha,A,mu,eta)
    CALL ComputeFEPProfile(1,SIZE(energyGap,1),mappingEnergies(:,:,:,1),mask(:,:),profile=G_FEP)
    CALL Histogram(energyGap(:,:),mask,Nbins,binPopulations,binIndices,binMidpoints)
    CALL FepUS(mappingEnergies(:,:,:,1),groundStateEnergy(:,:),G_FEP,binPopulations,binIndices,PMF1D=binGg,minPop=minPop,useBin=printBin)
    CALL ScanFepUs(binMidpoints(:),binGg(:),mask=printBin,stationaryPoints=relative)

    relative(:) = relative(:) - relative(1)

    objectFunction = 0.0d0
    IF (optAlpha    .EQV. .TRUE.) objectFunction = objectFunction + (relative(3) - dGPS)**2.0d0
    IF (optCoupling .EQV. .TRUE.) objectFunction = objectFunction + (relative(2) - dGTS)**2.0d0
    objectFunction = SQRT(objectFunction) ! costs time but gives object function units of energy

  END FUNCTION objectFunction

END MODULE ObjectFunctions

max_stars_repo_name: MJLMills/fepcat

max_issues_repo_name: MJLMills/fepcat

max_forks_repo_name: MJLMills/fepcat


text:
module mod_function
#include <messenger.h>
    use mod_kinds,      only: rk, ik
    use type_function,  only: function_t
    use type_fcnvector, only: fcnvector_t
    use type_point,     only: point_t

    !
    ! Import functions
    !
    use fcn_xsquared,                       only: xsquared_f
    use fcn_ysquared,                       only: ysquared_f
    use fcn_zsquared,                       only: zsquared_f
    use fcn_xyz,                            only: xyz_f
    use fcn_xlinear,                        only: xlinear_f
    use fcn_radius,                         only: radius_f
    use fcn_gaussian,                       only: gaussian_f
    use fcn_constant,                       only: constant_f
    use fcn_sine,                           only: sine_f
    use fcn_turbine_bc_sine,                only: turbine_bc_sine_f
    use fcn_polynomial,                     only: polynomial_f
    use fcn_convecting_vortex,              only: convecting_vortex_f
    use fcn_scalar_adv_diff_bl_solution,    only: scalar_adv_diff_bl_solution_f
    use fcn_pressure_pulse,                 only: pressure_pulse_f
    use fcn_euler_gradients,                only: euler_gradients_f
    use fcn_isentropic_vortex,              only: isentropic_vortex_f
    use fcn_monopole,                       only: monopole_f
    implicit none

    !
    ! Global vector of registered functions
    !
    type(fcnvector_t)   :: registered_fcns
    logical             :: initialized = .false.

contains

    !>  Register functions in a module vector.
    !!
    !!  This allows the available functions to be queried in the same way that they
    !!  are registered for allocation.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/9/2016
    !!
    !!
    !--------------------------------------------------------------------------------------------
    subroutine register_functions()
        integer :: nfcns, ifcn

        !
        ! Instantiate functions
        !
        type(xsquared_f)                        :: xsquared
        type(ysquared_f)                        :: ysquared
        type(zsquared_f)                        :: zsquared
        type(xyz_f)                             :: xyz
        type(xlinear_f)                         :: xlinear
        type(radius_f)                          :: radius
        type(gaussian_f)                        :: gaussian
        type(convecting_vortex_f)               :: convecting_vortex
        type(constant_f)                        :: constant
        type(sine_f)                            :: sin_function
        type(turbine_bc_sine_f)                 :: turbine_bc_sin_function
        type(polynomial_f)                      :: polynomial
        type(scalar_adv_diff_bl_solution_f)     :: scalar_adv_diff_bl_solution
        type(pressure_pulse_f)                  :: pressure_pulse
        type(euler_gradients_f)                 :: euler_gradients
        type(isentropic_vortex_f)               :: isentropic_vortex

        !
        ! Acoustics
        !
!        type(cylindricalduct_eigenfunction_f)   :: cylindricalduct_eigenfunction
        type(monopole_f)                        :: monopole

        if ( .not. initialized ) then
            !
            ! Register in global vector
            !
            call registered_fcns%push_back(xsquared)
            call registered_fcns%push_back(ysquared)
            call registered_fcns%push_back(zsquared)
            call registered_fcns%push_back(xyz)
            call registered_fcns%push_back(xlinear)
            call registered_fcns%push_back(radius)
            call registered_fcns%push_back(gaussian)
            call registered_fcns%push_back(constant)
            call registered_fcns%push_back(sin_function)
            call registered_fcns%push_back(turbine_bc_sin_function)
            call registered_fcns%push_back(polynomial)
!            call registered_fcns%push_back(cylindricalduct_eigenfunction)
            call registered_fcns%push_back(monopole)
            call registered_fcns%push_back(convecting_vortex)
            call registered_fcns%push_back(scalar_adv_diff_bl_solution)
            call registered_fcns%push_back(pressure_pulse)
            call registered_fcns%push_back(euler_gradients)
            call registered_fcns%push_back(isentropic_vortex)

            !
            ! Initialize each boundary condition in set. Doesn't need modified.
            !
            nfcns = registered_fcns%size()
            do ifcn = 1,nfcns
                call registered_fcns%data(ifcn)%fcn%init()
            end do

            !
            ! Confirm initialization
            !
            initialized = .true.

        end if

    end subroutine register_functions
    !********************************************************************************************

    !> Factory method for allocating concrete functions
    !!
    !!      - Allocate a concrete function_t based on the incoming string specification.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/9/2016
    !!
    !!  @param[in]      string  Character string used to select the appropriate boundary condition
    !!  @param[inout]   fcn      Allocatable boundary condition
    !!
    !--------------------------------------------------------------
    subroutine create_function(fcn,string)
        class(function_t),  allocatable,    intent(inout)   :: fcn
        character(*),                       intent(in)      :: string

        integer(ik) :: ierr, fcnindex

        if ( allocated(fcn) ) deallocate(fcn)

        !
        ! Find equation set in 'registered_bcs' vector
        !
        fcnindex = registered_fcns%index_by_name(trim(string))

        !
        ! Check function was found in 'registered_fcns'
        !
        if (fcnindex == 0) call chidg_signal_one(FATAL,"create_function: function not recognized", trim(string))

        !
        ! Allocate conrete function_t instance
        !
        allocate(fcn, source=registered_fcns%data(fcnindex)%fcn, stat=ierr)
        if (ierr /= 0) call chidg_signal(FATAL,"create_function: error allocating function from global vector.")

        !
        ! Check boundary condition was allocated
        !
        if ( .not. allocated(fcn) ) call chidg_signal(FATAL,"create_function: error allocating concrete function.")

    end subroutine create_function
    !*****************************************************************************************

    !>  Print a list of the registered functions. Really just a utility for 'chidg edit' to
    !!  dynamically list the available 'function_t's.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   11/8/2016
    !!
    !!
    !------------------------------------------------------------------------------------------
    subroutine list_functions()
        integer                         :: nfcns, ifcn
        character(len=:),   allocatable :: fcn_name

        nfcns = registered_fcns%size()

        do ifcn = 1,nfcns

            fcn_name = registered_fcns%data(ifcn)%fcn%get_name()
            call write_line(trim(fcn_name))

        end do ! ifcn

    end subroutine list_functions
    !******************************************************************************************

end module mod_function

max_stars_repo_name: nwukie/ChiDG

max_issues_repo_name: nwukie/ChiDG

max_forks_repo_name: nwukie/ChiDG


text:
      SUBROUTINE MSGWRT
C
C     MSGWRT WILL PRINT THE INDICATED ERROR MESSAGES ON THE OUTPUT TAPE
C
      INTEGER         OUTTAP,NAME(2),POS(2),NEG(2),PNG(2)
      DIMENSION       XMSG(4,1),IPAG(2)
      CHARACTER       UFM*23,UWM*25,UIM*29,SFM*25,SWM*27
      COMMON /XMSSG / UFM,UWM,UIM,SFM,SWM
      COMMON /MACHIN/ MACH
      COMMON /SYSTEM/ SYSBUF,OUTTAP
      COMMON /MSGX  / N,M,MSG(4,1)
      EQUIVALENCE     (XMSG(1,1),MSG(1,1))
      DATA   POS,NEG/ 4HWARN,4HING ,4HFATA,4HL    /
      DATA   NMSGS  / 117/ , IPAG / 4H PAG,4HE2   /
C
      DO 99 I = 1,N
      L = IABS(MSG(1,I))
      IF (MACH.EQ.3 .AND. L.GE.1125 .AND. L.LE.1320) GO TO 80
C
C     *** NOTE ***  CHANGE IF STATEMENT WHEN YOU CHANGE GO TO
C                   MAKE SURE MESSAGE NO. IS WITHIN GO TO RANGE
C
      IF (L .GT. NMSGS) GO TO 98
      IF (L .EQ.    30) GO TO 30
      IF (MSG(3,I).NE.IPAG(1) .AND. MSG(4,I).NE.IPAG(2)) CALL PAGE2 (4)
      IF (L.GE.71 .AND. L.LE.NMSGS) GO TO 210
C
C     --- NOTE --- INCREASE THE UPPER LIMIT TO ADD MORE MESSAGES
C
      LPLUS = L + 3000
      DO 205 J = 1,2
      PNG(J) = POS(J)
      IF (MSG(1,I) .LT. 0) PNG(J) = NEG(J)
  205 CONTINUE
      CALL FNAME (MSG(2,I),NAME)
C
      GO TO (  1,  2,  3,  4,  5,  6,  7,  8,  9, 10,
     1        11, 12, 13, 14, 15, 16, 17, 18, 19, 20,
     2        21, 22, 23, 24, 25, 26, 27, 28, 29, 30,
     3        31, 32, 33, 34, 35, 36, 37, 38, 39, 40,
     4        41, 42, 43, 44, 45, 46, 47, 48, 49, 50,
     5        51, 52, 53, 54, 55, 56, 57, 58, 59, 60,
     6        61, 62, 63, 64, 65, 66, 67, 68, 69, 70), L
C
C     *** CHANGE L INTO CORRECT GINO.NASTIO.PACKUNPK ERROR NUMBER
C
  210 LPLUS = L + 1055
      WRITE (OUTTAP,2005) SFM,LPLUS
C
C     *** BRANCH TO PRINT APPROPRIATE ERROR MESSAGE
C     --- NOTE - EACH NEW MESSAGE REQUIRES A NEW PRINT STATEMENT
C
      LPLUS = L - 70
      GO TO ( 226,  227,  228,  229,  230,  231,  232,  233,  234,
     9  235,  236,  237,  238,  239,  240,  241,  242,  243,  244,
     8  245,  246,  247,  248,  249,  250,  251,  252,  253,  254,
     7  255,  256,  257,  258,  259,  260,  261,  262,  263,  264,
     6  265,  266,  267,  268,  269,  270,  271,  272), LPLUS
C
C     *** GINO FORMAT NUMBERS MATCH THE MESSAGE NUMBER.
C
  226 WRITE (OUTTAP,1126)
      GO TO 99
  227 WRITE (OUTTAP,1127)
      GO TO 99
  228 WRITE (OUTTAP,1128)
      GO TO 99
  229 WRITE (OUTTAP,1129)
      GO TO 99
  230 WRITE (OUTTAP,1130)
      GO TO 99
  231 WRITE (OUTTAP,1131)
      GO TO 99
  232 WRITE (OUTTAP,1132)
      GO TO 99
  233 WRITE (OUTTAP,1133)
      GO TO 99
  234 WRITE (OUTTAP,1134)
      GO TO 99
  235 WRITE (OUTTAP,1135)
      GO TO 99
  236 WRITE (OUTTAP,1136)
      GO TO 99
  237 WRITE (OUTTAP,1137)
      GO TO 99
  238 WRITE (OUTTAP,1138)
      GO TO 99
  239 WRITE (OUTTAP,1139)
      GO TO 99
  240 WRITE (OUTTAP,1140)
      GO TO 99
  241 WRITE (OUTTAP,1141)
      GO TO 99
  242 WRITE (OUTTAP,1142)
      GO TO 99
  243 WRITE (OUTTAP,1143)
      GO TO 99
  244 WRITE (OUTTAP,1144)
      GO TO 99
  245 WRITE (OUTTAP,1145)
      GO TO 99
  246 WRITE (OUTTAP,1146)
      GO TO 99
  247 WRITE (OUTTAP,1147)
      GO TO 99
  248 WRITE (OUTTAP,1148)
      GO TO 99
  249 WRITE (OUTTAP,1149)
      GO TO 99
  250 WRITE (OUTTAP,1150)
      GO TO 99
  251 WRITE (OUTTAP,1151)
      GO TO 99
  252 WRITE (OUTTAP,1152)
      GO TO 99
  253 WRITE (OUTTAP,1153)
      GO TO 99
  254 WRITE (OUTTAP,1154)
      GO TO 99
  255 WRITE (OUTTAP,1155)
      GO TO 99
  256 WRITE (OUTTAP,1156)
      GO TO 99
  257 WRITE (OUTTAP,1157)
      GO TO 99
  258 WRITE (OUTTAP,1158)
      GO TO 99
  259 WRITE (OUTTAP,1159)
      GO TO 99
  260 WRITE (OUTTAP,1160)
      GO TO 99
  261 WRITE (OUTTAP,1161)
      GO TO 99
  262 WRITE (OUTTAP,1162) SFM
      GO TO 99
  263 WRITE (OUTTAP,1163) SFM
      GO TO 99
  264 WRITE (OUTTAP,1164)
      GO TO 99
  265 WRITE (OUTTAP,1165)
      GO TO 99
  266 WRITE (OUTTAP,1166) SFM
      GO TO 99
  267 WRITE (OUTTAP,1167) SFM
      GO TO 99
  268 WRITE (OUTTAP,1168)
      GO TO 99
  269 WRITE (OUTTAP,1169) SFM
      GO TO 99
  270 WRITE (OUTTAP,1170)
      GO TO 99
  271 WRITE (OUTTAP,1171)
      GO TO 99
  272 WRITE (OUTTAP,1172) SFM
      GO TO 99
C
C    *** END OF GINO ERRORS SECTION
C
    1 WRITE (OUTTAP,2000) PNG,LPLUS
      WRITE (OUTTAP,101 ) MSG(2,I),MSG(3,I),MSG(4,I)
      GO TO 99
    2 WRITE (OUTTAP,2000) PNG,LPLUS
      WRITE (OUTTAP,102 ) NAME,MSG(2,I),MSG(3,I),MSG(4,I)
      GO TO 99
    3 WRITE (OUTTAP,2000) PNG,LPLUS
      WRITE (OUTTAP,103 ) NAME,MSG(2,I),MSG(3,I),MSG(4,I)
      GO TO 99
    4 WRITE (OUTTAP,2005) SFM,LPLUS
      WRITE (OUTTAP,104 ) NAME
      GO TO 99
    5 WRITE (OUTTAP,2001) PNG,LPLUS
      WRITE (OUTTAP,105 ) NAME,MSG(3,I),MSG(4,I)
      GO TO 99
    6 WRITE (OUTTAP,106 ) SFM,MSG(3,I),MSG(4,I),MSG(2,I)
      GO TO 99
    7 WRITE (OUTTAP,2005) SFM,LPLUS
      WRITE (OUTTAP,107 ) MSG(3,I),MSG(4,I)
      IF (MSG(1,I) .GE. 0) GO TO 99
      CALL ERRTRC ('MSGWRT  ',0)
      GO TO 99
    8 WRITE (OUTTAP,2000) PNG,LPLUS
      WRITE (OUTTAP,108 ) MSG(3,I),MSG(4,I)
      IF (MSG(2,I) .GT.0) WRITE (OUTTAP,1081) MSG(2,I)
      J = -MSG(2,I)
      IF (J .GT. 0) WRITE (OUTTAP,1082) J
      IF (MACH.EQ.3 .OR. MACH.EQ.5) WRITE (OUTTAP,1083)
      GO TO 99
    9 WRITE (OUTTAP,2000) PNG,LPLUS
      WRITE (OUTTAP,109 ) NAME,MSG(2,I)
      GO TO 99
   10 WRITE (OUTTAP,2000) PNG,LPLUS
      WRITE (OUTTAP,110 ) NAME,MSG(2,I)
      GO TO 99
   11 WRITE (OUTTAP,2000) PNG,LPLUS
      WRITE (OUTTAP,111 ) MSG(2,I)
      GO TO 99
   12 WRITE (OUTTAP,2000) PNG,LPLUS
      WRITE (OUTTAP,112 ) NAME,MSG(2,I)
      GO TO 99
   13 WRITE (OUTTAP,2000) PNG,LPLUS
      WRITE (OUTTAP,113 ) NAME,MSG(2,I)
      GO TO 99
   14 WRITE (OUTTAP,2000) PNG,LPLUS
      WRITE (OUTTAP,114 ) NAME,MSG(2,I)
      GO TO 99
   15 WRITE (OUTTAP,2000) PNG,LPLUS
      WRITE (OUTTAP,115 ) NAME,MSG(2,I)
      GO TO 99
   16 WRITE (OUTTAP,2005) SFM,LPLUS
      WRITE (OUTTAP,116 ) NAME,MSG(3,I),MSG(4,I)
      GO TO 99
   17 WRITE (OUTTAP,2010) UWM,LPLUS
      IF (MSG(2,I) .EQ. 0) WRITE (OUTTAP,117 )
      IF (MSG(2,I) .NE. 0) WRITE (OUTTAP,1175)
      GO TO 99
   18 WRITE (OUTTAP,2000) PNG,LPLUS
      WRITE (OUTTAP,118 ) MSG(3,I),MSG(4,I),MSG(2,I)
      GO TO 99
   19 WRITE (OUTTAP,2015) UFM,LPLUS
      WRITE (OUTTAP,119 ) MSG(3,I),MSG(4,I),MSG(2,I)
      GO TO 99
   20 WRITE (OUTTAP,2000) PNG,LPLUS
      WRITE (OUTTAP,120 ) MSG(2,I),MSG(3,I),MSG(4,I)
      GO TO 99
   21 WRITE (OUTTAP,2000) PNG,LPLUS
      WRITE (OUTTAP,121 ) MSG(2,I)
      GO TO 99
   22 WRITE (OUTTAP,2025) SWM,LPLUS
      WRITE (OUTTAP,2026)
      WRITE (OUTTAP,122 ) MSG(3,I),MSG(4,I)
      GO TO 99
   23 CONTINUE
      WRITE (OUTTAP,123 ) UIM,MSG(2,I),MSG(3,I),MSG(4,I)
      GO TO 99
   24 WRITE (OUTTAP,2020) UIM,LPLUS
      WRITE (OUTTAP,124 ) NAME,MSG(3,I)
      GO TO 99
   25 WRITE (OUTTAP,2005) SFM,LPLUS
      WRITE (OUTTAP,125 ) MSG(3,I),MSG(4,I)
      GO TO 99
   26 WRITE (OUTTAP,2005) SFM,LPLUS
      WRITE (OUTTAP,126 ) NAME,MSG(3,I),MSG(4,I)
      GO TO 99
   27 WRITE (OUTTAP,2020) UIM,LPLUS
      WRITE (OUTTAP,127 ) MSG(2,I)
      GO TO 99
   28 CONTINUE
      WRITE (OUTTAP,128 ) UIM,MSG(2,I),MSG(3,I),MSG(4,I)
      GO TO 99
   29 WRITE (OUTTAP,129 ) SFM,NAME,MSG(2,I)
      GO TO 99
   30 CALL USRMSG (I)
      GO TO 99
   31 CONTINUE
   32 WRITE (OUTTAP,2015) UFM,LPLUS
      WRITE (OUTTAP,132 ) MSG(2,I),MSG(3,I),MSG(4,I)
      GO TO 99
   33 WRITE (OUTTAP,133 ) UFM,MSG(2,I)
      GO TO 99
   34 WRITE (OUTTAP,2010) UWM,LPLUS
      WRITE (OUTTAP,134 ) XMSG(2,I),XMSG(3,I)
      GO TO 99
   35 WRITE (OUTTAP,2020) UIM,LPLUS
      WRITE (OUTTAP,135 ) MSG(2,I),XMSG(3,I)
      GO TO 99
   36 WRITE (OUTTAP,2000) PNG,LPLUS
      WRITE (OUTTAP,136 ) MSG(3,I),MSG(4,I)
      GO TO 99
   37 WRITE (OUTTAP,2000) PNG,LPLUS
      WRITE (OUTTAP,137 ) MSG(3,I),MSG(4,I)
      GO TO 99
   38 WRITE (OUTTAP,2000) PNG,LPLUS
      WRITE (OUTTAP,138 ) MSG(2,I)
      GO TO 99
   39 WRITE (OUTTAP,139 ) SFM
      GO TO 99
   40 WRITE (OUTTAP,2000) PNG,LPLUS
      WRITE (OUTTAP,140 ) NAME,MSG(2,I)
      GO TO 99
   41 WRITE (OUTTAP,2010) UWM,LPLUS
      WRITE (OUTTAP,141 ) MSG(2,I)
      GO TO 99
   42 WRITE (OUTTAP,2010) UWM,LPLUS
      WRITE (OUTTAP,142 ) XMSG(2,I)
      GO TO 99
   43 WRITE (OUTTAP,2015) UFM,LPLUS
      WRITE (OUTTAP,143 ) MSG(2,I),MSG(3,I),MSG(4,I)
      GO TO 99
   44 WRITE (OUTTAP,2015) UFM,LPLUS
      WRITE (OUTTAP,144 ) MSG(2,I),MSG(3,I)
      GO TO 99
   45 WRITE (OUTTAP,145 ) UWM,MSG(2,I),MSG(3,I),MSG(4,I)
      GO TO 99
   46 WRITE (OUTTAP,146 ) UFM
      GO TO 99
   47 WRITE (OUTTAP,147 ) UFM
      GO TO 99
   48 WRITE (OUTTAP,148 ) SFM,MSG(2,I),MSG(3,I),MSG(4,I)
      GO TO 99
   49 WRITE (OUTTAP,149 ) SFM,MSG(3,I),MSG(4,I),MSG(2,I)
      GO TO 99
   50 WRITE (OUTTAP,150 ) SFM,MSG(3,I),MSG(4,I),MSG(2,I)
      GO TO 99
   51 WRITE (OUTTAP,151 ) UFM,MSG(2,I)
      GO TO 99
   52 WRITE (OUTTAP,152 ) UWM,MSG(2,I),MSG(3,I),MSG(4,I)
      GO TO 99
   53 WRITE (OUTTAP,153 ) UWM,MSG(2,I),MSG(3,I)
      GO TO 99
   54 WRITE (OUTTAP,154 ) UWM,MSG(2,I),XMSG(3,I)
      GO TO 99
   55 WRITE (OUTTAP,2001) PNG,LPLUS
      WRITE (OUTTAP,155 ) MSG(3,I),MSG(4,I)
      GO TO 99
   56 WRITE (OUTTAP,2001) PNG,LPLUS
      WRITE (OUTTAP,156 )
      GO TO 99
   57 WRITE (OUTTAP,2001) PNG,LPLUS
      WRITE (OUTTAP,157 ) NAME
      GO TO 99
   58 WRITE (OUTTAP,2001) PNG,LPLUS
      WRITE (OUTTAP,158 ) XMSG(2,I),MSG(3,I)
       GO TO 99
   59 WRITE (OUTTAP,2001) PNG,LPLUS
      WRITE (OUTTAP,159 ) MSG(2,I),MSG(3,I),MSG(4,I)
      GO TO 99
   60 WRITE (OUTTAP,160 ) UFM
      GO TO 99
   61 CONTINUE
      GO TO 99
   62 WRITE (OUTTAP,162 ) SFM
      GO TO 99
   63 WRITE (OUTTAP,163 ) SFM
      GO TO 99
   64 WRITE (OUTTAP,164 ) SFM
      GO TO 99
   65 WRITE (OUTTAP,165 ) SFM
      GO TO 99
   66 WRITE (OUTTAP,166 ) SFM
      GO TO 99
   67 WRITE (OUTTAP,167 ) SFM
      GO TO 99
   68 WRITE (OUTTAP,168 ) SFM
      GO TO 99
   69 WRITE (OUTTAP,169 ) SFM
      GO TO 99
   70 WRITE (OUTTAP,170 ) SFM
      GO TO 99
   80 CALL MSGUNI (L)
      GO TO 99
   98 WRITE (OUTTAP,198 ) MSG(1,I),MSG(2,I),MSG(3,I),MSG(4,I)
   99 CONTINUE
      IF (N .GE. M) WRITE (OUTTAP,199) UWM,M
      I = N
      N = 0
      IF (MSG(1,I) .GE. 0) GO TO 1000
CWKBI WRITE (OUTTAP,100)
      CALL ERRTRC ('WRTMSG  ',100)
 1000 RETURN
C
C
C 100 FORMAT ('0FATAL ERROR')
  101 FORMAT ('0ATTEMPT TO OPEN DATA SET',I4,' IN SUBROUTINE ',A4,A2,
     1        ', WHICH WAS NOT DEFINED IN THE FIST')
  102 FORMAT ('0EOF ENCOUNTERED WHILE READING DATA SET ',2A4,'(FILE',
     1        I4,') IN SUBROUTINE ',2A4)
  103 FORMAT ('0ATTEMPT TO READ PAST THE END OF A LOGICAL RECORD IN ',
     1        'DATA SET ',2A4,'(FILE',I4,') IN SUBROUTINE ',2A4)
  104 FORMAT ('0INCONSISTENT TYPE FLAGS ENCOUNTERED WHILE PACKING DATA',
     1        'SET ',2A4)
  105 FORMAT ('0ATTEMPT TO OPERATE ON THE SINGULAR MATRIX ',2A4,
     1        ' IN SUBROUTINE ',2A4)
  106 FORMAT (A25,' 3006, BUFFER ASSIGNED WHEN OPENING DATA BLOCK ',2A4,
     1        6H,FILE ,I5,1H,, /5X,'CONFLICTS WITH BUFFERS CURRENTLY ',
     2        'OPEN.')
  107 FORMAT ('0ILLEGAL INPUT TO SUBROUTINE ',2A4)
  108 FORMAT ('0INSUFFICIENT CORE AVAILABLE FOR SUBROUTINE ',2A4)
 1081 FORMAT (' ADDITIONAL CORE REQUIRED =',I10,' WORDS.')
 1082 FORMAT (' PRESENT OPEN CORE SIZE =',I10,' WORDS.')
 1083 FORMAT (' USE NASTRAN HICORE CARD TO INCREASE CORE SIZE')
  109 FORMAT ('0DATA TRANSMISSION ERROR ON DATA SET ',2A4,'(FILE',I4,
     1        1H))
  110 FORMAT ('0ATTEMPT TO MANIPULATE DATA SET ',2A4,'(FILE',I4,
     1        ' BEFORE OPENING THE FILE')
  111 FORMAT ('0ATTEMPT TO WRITE A TRAILER ON FILE',I4,
     1        ' WHEN IT HAS BEEN PURGED')
  112 FORMAT ('0ATTEMPT TO OPEN DATA SET ',2A4,'(FILE',I4,
     1        ') WHICH HAS ALREADY BEEN OPENED')
  113 FORMAT ('0ATTEMPT TO READ DATA SET ',2A4,'(FILE',I4,
     1        ') WHEN IT WAS OPENED FOR OUTPUT')
  114 FORMAT ('0ATTEMPT TO WRITE DATA SET ',2A4,'(FILE',I4,
     1        ') WHEN IT WAS OPENED FOR INPUT')
  115 FORMAT ('0ATTEMPT TO FWDREC ON DATA SET ',2A4,'(FILE',I4,
     1        ') WHEN IT WAS OPENED FOR OUTPUT')
  116 FORMAT (1H0,2A4,' MATRIX IS NOT IN PROPER FORM IN SUBROUTINE ',
     1        2A4)
  117 FORMAT ('0    ONE OR MORE POTENTIAL SINGULARITIES HAVE NOT BEEN ',
     1        'REMOVED BY SINGLE OR MULTI-POINT CONSTRAINTS.', /5X,
     2        '(USER COULD REQUEST NASTRAN AUTOMATIC SPC GENERATION ',
     3        'VIA A ''PARAM AUTOSPC'' BULK DATA CARD)')
 1175 FORMAT ('0    ONE OR MORE POTENTIAL SINGULARITIES HAVE NOT BEEN ',
     1        'REMOVED BY SINGLE OR MULTI-POINT CONSTRAINTS.')
  118 FORMAT ('0MODULE ',2A4,', SEQUENCE NO.',I5,
     1        ', REQUIREMENTS EXCEED AVAILABLE FILES')
  119 FORMAT ('0MAXIMUM LINE COUNT EXCEEDED IN SUBROUTINE ',2A4,
     1        ' LINE COUNT EQUALS',I8)
  120 FORMAT ('0GNFIST OVERFLOWED FIST TABLE AT SEQUENCE NO.',I5,
     1        '  DATA SET ',2A4)
  121 FORMAT ('0FILE',I4,' NOT DEFINED IN FIST')
  122 FORMAT (5X,'DATA BLOCK ',2A4,' MAY BE REQUIRED AS INPUT AND IS ',
     1        'NOT OUTPUT BY A PREVIOUS MODULE IN THE CURRENT DMAP ',
     2        'ROUTE.')
  123 FORMAT (A29,' 3028   B =',I5,' C =',I5,' R =',I5)
  124 FORMAT ('0THE BANDWIDTH OF MATRIX ',2A4,' EXCEEDS THE MAXIMUM ',
     1        'BANDWIDTH. A MAXIMUM BANDWIDTH OF',I5,' WILL BE USED')
  125 FORMAT ('0ILLEGAL INDEX IN ACTIVE ROW OR COLUMN CALCULATION IN ',
     1        2A4)
  126 FORMAT ('0MATRIX ',2A4,' EXCEEDS MAXIMUM ALLOWABLE SIZE FOR BAND',
     1        'WIDTH PLUS ACTIVE COLUMNS. BMAX =',I6,' CMAX =',I6)
  127 FORMAT ('0DECOMPOSITION TIME ESTIMATE IS',I6)
  128 FORMAT (A29,' 3028, BBAR =',I5,' CBAR =',I5,' R =',I5)
  129 FORMAT (A25,' 3029, PHYSICAL EOF ENCOUNTERED ON DATA SET ',2A4,
     1        ' (FILE',I4,3H ).)
  132 FORMAT ('0UNABLE TO FIND SELECTED SET (',I8,') IN TABLE (',A4,
     1        ') IN SUBROUTINE (',A4,2H).)
  133 FORMAT (A23,' 3033, SUBCASE ID',I9,' IS REFERENCED ON ONE OR MORE'
     1,       ' RANDPS CARDS', /5X,'BUT IS NOT A CURRENT SUBCASE ID.')
  134 FORMAT ('0ORTHOGONALITY CHECK FAILED, LARGEST TERM = ',1P,E14.7,
     1        ', EPSILON = ',1P,E14.7)
  135 FORMAT (5X,'FOR SUBCASE NUMBER',I6,', EPSILON SUB E = ',1P,E15.7)
  136 FORMAT ('0DATA SET ',2A4,' IS REQUIRED AS INPUT BUT HAS NOT ',
     1        'BEEN GENERATED OR PURGED')
  137 FORMAT ('0JOB TERMINATED IN SUBROUTINE ',2A4)
  138 FORMAT ('0DATA SET ',A4,' DOES NOT HAVE MULTI-REEL CAPABILITY')
  139 FORMAT (A25,' 3039, ENDSYS CANNOT FIND SAVE FILE.')
  140 FORMAT ('0ATTEMPT TO WRITE DATA SET ',2A4,'(FILE',I4,
     1        ') WHEN IT IS AN INPUT FILE')
  141 FORMAT ('0EXTERNAL GRID POINT',I9,' DOES NOT EXIST OR IS NOT A ',
     1        'GEOMETRIC GRID POINT.',
     2        /5X,'THE BASIC ORIGIN WILL BE USED.')
  142 FORMAT ('0INCONSISTENT SCALAR MASSES HAVE BEEN USED.  EPSILON/',
     1        'DELTA = ',1P,E15.7)
  143 FORMAT ('0UNCONNECTED EXTRA POINT (MODAL COORDINATE =',I9,
     1        ') HAS BEEN DETECTED BY SUBROUTINE ',2A4)
  144 FORMAT ('0A POINT ON NON-LINEAR LOAD SET',I9,' NOLIN',I1,
     1        ' IS NOT AN EXTRA POINT.', /5X,'ONLY EXTRA POINTS MAY ',
     2        'HAVE NON-LINEAR LOADS IN A MODAL FORMULATION.')
  145 FORMAT (A25,' 3045, INSUFFICIENT TIME TO COMPLETE THE REMAINING',
     1        I6,' SOLUTION(S) IN MODULE ',2A4)
  146 FORMAT (A23,' 3046, YOUR SELECTED LOADING CONDITION, INITIAL ',
     1        'CONDITION, AND NON-LINEAR FORCES ARE NULL', /5X,
     2        'A ZERO SOLUTION WILL RESULT.')
  147 FORMAT (A23,' 3047, NO MODES WITHIN RANGE AND LMODES = 0. A MODAL'
     1,       ' FORMULATION CANNOT BE MADE.')
  148 FORMAT (A25,' 3048, BUFFER CONTROL WORD INCORRECT FOR GINO ',A4,
     1        ' OPERATION ON DATA BLOCK ',2A4)
  149 FORMAT (A25,' 3049, GINO UNABLE TO POSITION DATA BLOCK ',2A4,
     1        ' CORRECTLY DURING ',A4,' OPERATION.')
  150 FORMAT (A25,' 3050, INSUFFICIENT TIME REMAINING FOR ',2A4,
     1        '.  TIME ESTIMATE IS',I9,' SECONDS.')
  151 FORMAT (A23,' 3051, INITIAL CONDITION SET',I9,' WAS SELECTED FOR',
     1        ' A MODAL TRANSIENT PROBLEM.' ,/5X,
     2        'INITIAL CONDITIONS ARE NOT ALLOWED IN SUCH A PROBLEM.')
  152 FORMAT (A25,' 3052, A RANDOM REQUEST FOR CURVE TYPE - ',A4,
     1        ' -, POINT -',I9, /5X,'COMPONENT -',I4,
     2        ' -, SPECIFIES TOO LARGE A COMPONENT ID.  THE LAST ',
     3        'COMPONENT WILL BE USED.')
  153 FORMAT (A25,' 3053, THE ACCURACY OF EIGENVALUE',I6,' IS IN DOUBT.'
     1,       ' GIVENS-QR FAILED TO CONVERGE IN',I4,' ITERATIONS.')
  154 FORMAT (A25,' 3054, THE ACCURACY OF EIGENVECTOR',I6,' CORRESPOND',
     1        'ING TO THE EIGENVALUE ',1P,E15.7,' IS IN DOUBT.')
  155 FORMAT ('0AN ATTEMPT TO MULTIPLY OR MULTIPLY AND ADD NON-CONFOR',
     1        'MABLE MATRICES TOGETHER WAS MADE IN SUBROUTINE ',2A4)
  156 FORMAT ('0NO MASS MATRIX IS PRESENT BUT MASS DATA IS REQUIRED')
  157 FORMAT ('0MATRIX ',2A4,' IS NOT POSITIVE DEFINITE.')
  158 FORMAT ('0EPSILON IS LARGER THAN ',1P,E14.7,' FOR SUBCASE',I5)
  159 FORMAT ('0SET IDENTIFIER ',A4,' DOES NOT EXIST. ERROR DETECTED ',
     1        'IN SUBROUTINE ',2A4)
  160 FORMAT (A23,' 3060, READ MODULE FINDS THAT THE INPUT STIFFNESS ',
     1        'AND/OR MASS MATRIX IS NULL.')
  162 FORMAT (A25,' 3062, NO MESSAGE.')
  163 FORMAT (A25,' 3063, NO MESSAGE.')
  164 FORMAT (A25,' 3064, NO MESSAGE.')
  165 FORMAT (A25,' 3065, NO MESSAGE.')
  166 FORMAT (A25,' 3066, NO MESSAGE.')
  167 FORMAT (A25,' 3067, NO MESSAGE.')
  168 FORMAT (A25,' 3068, NO MESSAGE.')
  169 FORMAT (A25,' 3069, NO MESSAGE.')
  170 FORMAT (A25,' 3070, NO MESSAGE.')
  198 FORMAT ('0NO MESSAGE FOR MESSAGE NO. =',I5 ,/5X,'PARAMETERS = ',
     1        3I20)
  199 FORMAT (A25,' 3199, NON-FATAL MESSAGES MAY HAVE BEEN LOST BY ',
     1        'ATTEMPTING TO QUEUE MORE THAN',I5,' MESSAGES')
 1126 FORMAT ('0ADDRESS OF BUFFER LESS THAN ADDRESS OF /XNSTRN/.')
 1127 FORMAT ('0BUFFER ASSIGNED EXTENDS INTO MASTER INDEX AREA.')
 1128 FORMAT ('0ON AN OPEN CALL WITHOUT REWIND, THE BLOCK NUMBER READ ',
     1        'DOES NOT MATCH EXPECTED VALUE.')
 1129 FORMAT ('0ON A CALL WRITE THE WORD COUNT IS NEGATIVE.')
 1130 FORMAT ('0ON A CALL READ THE CONTROL WORD AT WHICH THE FILE IS ',
     1        'POSITIONED IS NOT ACCEPTABLE.')
 1131 FORMAT ('0LOGICAL RECORD TRAILER NOT RECOGNIZABLE AS SUCH.')
 1132 FORMAT ('0UNRECOGNIZABLE CONTROL WORD DURING PROCESSING OF A ',
     1        'BCKREC CALL.')
 1133 FORMAT ('0AFTER A POSITIONING CALL TO IO6600, DURING PROCESSING ',
     1        'OF A BCKREC CALL THE BLOCK READ WAS NOT THE EXPECTED ',
     2        'ONE.')
 1134 FORMAT ('0CALL SKPFIL IN A FORWARD DIRECTION ON A FILE NOT ',
     1        'OPENED FOR OUTPUT IS NOT SUPPORTED.')
 1135 FORMAT ('0FILPOS WAS CALLED ON A FILE OPENED FOR OUTPUT.')
 1136 FORMAT ('0ENDPUT WAS CALLED WITH BLOCK(8) EQUAL TO -1.')
 1137 FORMAT ('0MORE TERMS WRITTEN IN STRING THAN WERE AVAILABLE TO ',
     1        'WRITE.')
 1138 FORMAT ('0CURRENT BUFFER POINTER EXCEEDS LAST DATA WORD IN BLOCK')
 1139 FORMAT ('0ON AN INITIAL CALL TO GETSTR, THE RECORD IS NOT ',
     1        'POSITIONED AT THE COLUMN HEADER.')
 1140 FORMAT ('0STRING DEFINITION WORD NOT RECOGNIZABLE.')
 1141 FORMAT ('0FIRST WORD OF A DOUBLE PRECISION STRING IS NOT ON A ',
     1        'DOUBLE PRECISION BOUNDARY.')
 1142 FORMAT ('0CURRENT BUFFER POINTER IS BEYOND RANGE OF INFORMATION ',
     1        'IN BUFFER.')
 1143 FORMAT ('0ON AN INITIAL CALL TO GETSTB, THE FILE IS NOT ',
     1        'POSITIONED AT AN ACCEPTABLE POINT.')
 1144 FORMAT ('0END-OF-SEGMENT CONTROL WORD SHOULD HAVE IMMEDIATELY ',
     1        'PRECED CURRENT POSITION AND IT DID NOT.')
 1145 FORMAT ('0COLUMN TRAILER NOT FOUND.')
 1146 FORMAT ('0PREVIOUS RECORD TO BE READ BACKWARDS WAS NOT WRITTEN ',
     1        'WITH STRING TRAILERS.')
 1147 FORMAT ('0STRING RECOGNITION WORD NOT RECOGNIZED.')
 1148 FORMAT ('0RECORD CONTROL WORD NOT IN EXPECTED POSITION.')
 1149 FORMAT ('0RECTYP WAS CALLED FOR A FILE OPENED FOR OUTPUT.')
 1150 FORMAT ('0RECTYP MUST BE CALLED WHEN THE FILE IS POSITIONED AT ',
     1        'THE BEGINNING OF A RECORD.')
 1151 FORMAT ('ON A CALL TO OPEN THE BUFFER ASSIGNED OVERLAPS A ',
     1        'PREVIOUSLY ASSIGNED BUFFER.')
 1152 FORMAT ('0A CALL TO OPEN FOR AN ALREADY OPEN FILE.')
 1153 FORMAT ('0FILE NOT OPEN.')
 1154 FORMAT ('0GINO REFERENCE NAME NOT IN FIST OR FILE NOT OPEN.')
 1155 FORMAT ('0A CALL TO GETSTR OCCURRED WHEN THE FILE WAS POSITIONED',
     1        'AT END-OF-FILE.')
 1156 FORMAT ('0ATTEMPTED TO WRITE ON AN INPUT FILE.')
 1157 FORMAT ('0ATTEMPTED TO READ FROM AN OUTPUT FILE.')
 1158 FORMAT ('0A CALL TO BLDPK OR PACK IN WHICH EITHER TYPIN OR ',
     1        'TYPOUT IS OUT OF RANGE.')
 1159 FORMAT ('0ROW POSITIONS OF ELEMENTS FURNISHED TO ZBLPKI OR ',
     1        'BLDPKI ARE NOT IN A MONOTONIC INCREASING SEQUENCE.', /,
     2        ' (POSSIBLY DUE TO ROW OR COLUMN INDEX ERROR)')
 1160 FORMAT ('0ON A CALL TO BLDPKN, FILE NAME DOES NOT MATCH PREVIOUS',
     1        'CALLS.')
 1161 FORMAT ('0A CALL TO INTPK OR UNPACK IN WHICH TYPOUT IS OUT OF ',
     1        'RANGE.')
 1162 FORMAT (A25,' 1162, NO MESSAGE.')
 1163 FORMAT (A25,' 1163, NO MESSAGE.')
 1164 FORMAT ('0 FOLLOWING A READ ATTEMPT ON AN INDEXED FILE, EITHER ',
     1        'AN END-OF-FILE WAS ENCOUNTERED OR THE NUMBER OF WORDS ',
     2        'READ WAS INCORRECT.')
 1165 FORMAT ('0ON AN ATTEMPT TO READ A SEQUENTIAL FILE, AN END-OF-',
     1        'FILE OR AN END-OF-INFORMATION WAS ENCOUNTERED.')
 1166 FORMAT (A25,' 1166, NO MESSAGE.')
 1167 FORMAT (A25,' 1167, NO MESSAGE.')
 1168 FORMAT ('0A CALL TO IO6600 WITH OPCODE=5 (FORWARD SPACE) IS NOT ',
     1        'SUPPORTED.')
 1169 FORMAT (A25,' 1169, NO MESSAGE.')
 1170 FORMAT ('0ILLEGAL CALL TO NASTIO, LOGIC ERROR IN IO6600.')
 1171 FORMAT ('0ON A POSITION CALL, THE BLOCK NUMBER REQUESTED IS NOT ',
     1        'FOUND IN CORE WHEN IT IS EXPECTED THERE.')
 1172 FORMAT (A25,' 1172, NO MESSAGE.')
 2000 FORMAT (12H0*** SYSTEM ,2A4,8H MESSAGE,I5)
 2001 FORMAT (10H0*** USER ,2A4,9H MESSAGE ,I5)
 2005 FORMAT (A25,I5)
 2010 FORMAT (A25,I5)
 2015 FORMAT (A23,I5)
 2020 FORMAT (A29,I5)
 2025 FORMAT (A27,I5)
 2026 FORMAT (1H+,33X,'(SEE PROG. MANUAL SEC. 4.9.7, OR ',7HUSERS' ,
     1        'MANUAL P. 6.5-3)')
      END