SUBROUTINE CP_IFSP ( rimnem, cimnem, iret ) C************************************************************************ C* CP_IFSP * C* * C* This subroutine initializes the interface mnemonic arrays and sets * C* the pointers within COMMON / RINTFP / and COMMON / CINTFP /. * C* * C* CP_IFSP ( RIMNEM, CIMNEM, IRET ) * C* * C* Output parameters: * C* RIMNEM (*) CHAR* Interface mnemonics for reals * C* CIMNEM (*) CHAR* Interface mnemonics for chars * C* IRET INTEGER Return code * C* 0 = normal return * C* -1 = one or more pointers * C* could not be set * C* * C** * C* Log: * C* J. Ator/NCEP 07/06 * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'cpcmn.cmn' C* CHARACTER*(*) rimnem (*), cimnem (*) C* LOGICAL allok INTEGER iploc ( NRSIMN ) CHARACTER rifmn ( NRIMN )*8, cifmn ( NCIMN )*8 C* C* Establish equivalence between iploc ( ) and COMMON / RINTFP / C* EQUIVALENCE ( iploc (1), iryear ) C* DATA ( rifmn ( i ), i = 1, NRIMN ) + / 'YEAR' , 'MNTH' , 'DAYS' , 'HOUR' , 'MINU' , + 'SLAT' , 'SLON' , 'SELV' , 'PLTP' , + 'TMPK' , 'TMPKQA', 'TMPKQR', 'DWPK' , 'DWPKQA', 'DWPKQR', + 'DRCT' , 'DRCTQA', 'DRCTQR', 'SPED' , 'SPEDQA', 'SPEDQR', + 'PC1H' , 'PC1HQA', 'PC1HQR', 'TOSD' , 'TOSDQA', 'TOSDQR', + 'NSOL' , 'SLIN' , + 'SOLM' , + 'SOLMQA', 'SOLMQR', + 'SOLT' , + 'SOLTQA', 'SOLTQR', + MLM1T7 * ' ' , + 'NSNW' , 'SNHR' , + 'DOFS' , + 'DOFSQA', 'DOFSQR', + MNM1T4 * ' ' / C* Real interface mnemonics C* DATA ( cifmn ( i ), i = 1, NCIMN ) + / 'STID' , 'PRVID' , + 'TMPKQD', 'DWPKQD', 'DRCTQD', 'SPEDQD', 'PC1HQD', 'TOSDQD', + 'SOLMQD', MSLM1 * ' ', + 'SOLTQD', MSLM1 * ' ', + 'DOFSQD', MSNM1 * ' ' / C* Character interface mnemonics C----------------------------------------------------------------------- iret = 0 C C* Initialize the interface mnemonics. C DO i = 1, NRIMN rimnem ( i ) = rifmn ( i ) END DO DO i = 1, NCIMN cimnem ( i ) = cifmn ( i ) END DO C C* The logical variable "allok" is initially set to .true. but will C* be reset to .false. if any of the pointers cannot be set. C allok = .true. C C* Set the pointers for the single-level interface mnemonics. C DO ii = 1, NRSIMN CALL DC_IFFP ( rimnem (ii), rimnem, NRIMN, allok, + iploc (ii), ier ) END DO C CALL DC_IFFP ( 'STID' , cimnem, NCIMN, allok, icstid , ier ) CALL DC_IFFP ( 'PRVID' , cimnem, NCIMN, allok, icprvid , ier ) CALL DC_IFFP ( 'TMPKQD', cimnem, NCIMN, allok, ictmpkqd, ier ) CALL DC_IFFP ( 'DWPKQD', cimnem, NCIMN, allok, icdwpkqd, ier ) CALL DC_IFFP ( 'DRCTQD', cimnem, NCIMN, allok, icdrctqd, ier ) CALL DC_IFFP ( 'SPEDQD', cimnem, NCIMN, allok, icspedqd, ier ) CALL DC_IFFP ( 'PC1HQD', cimnem, NCIMN, allok, icpc1hqd, ier ) CALL DC_IFFP ( 'TOSDQD', cimnem, NCIMN, allok, ictosdqd, ier ) C C* Set the pointers for the multi-level interface mnemonics. C CALL DC_IFFP ( 'NSOL' , rimnem, NRIMN, allok, irnsol, ier ) CALL DC_IFFP ( 'SLIN' , rimnem, NRIMN, allok, + irslin (1) , ier ) CALL DC_IFMP ( 7, MXSOL, irslin, ier ) CALL DC_IFFP ( 'SOLM' , rimnem, NRIMN, allok, + irsolm (1) , ier ) CALL DC_IFMP ( 7, MXSOL, irsolm, ier ) CALL DC_IFFP ( 'SOLMQA', rimnem, NRIMN, allok, + irsolmqa (1), ier ) CALL DC_IFMP ( 7, MXSOL, irsolmqa, ier ) CALL DC_IFFP ( 'SOLMQR', rimnem, NRIMN, allok, + irsolmqr (1), ier ) CALL DC_IFMP ( 7, MXSOL, irsolmqr, ier ) CALL DC_IFFP ( 'SOLMQD', cimnem, NCIMN, allok, + icsolmqd (1), ier ) CALL DC_IFMP ( 1, MXSOL, icsolmqd, ier ) CALL DC_IFFP ( 'SOLT' , rimnem, NRIMN, allok, + irsolt (1) , ier ) CALL DC_IFMP ( 7, MXSOL, irsolt, ier ) CALL DC_IFFP ( 'SOLTQA', rimnem, NRIMN, allok, + irsoltqa (1), ier ) CALL DC_IFMP ( 7, MXSOL, irsoltqa, ier ) CALL DC_IFFP ( 'SOLTQR', rimnem, NRIMN, allok, + irsoltqr (1), ier ) CALL DC_IFMP ( 7, MXSOL, irsoltqr, ier ) CALL DC_IFFP ( 'SOLTQD', cimnem, NCIMN, allok, + icsoltqd (1), ier ) CALL DC_IFMP ( 1, MXSOL, icsoltqd, ier ) C CALL DC_IFFP ( 'NSNW' , rimnem, NRIMN, allok, irnsnw, ier ) CALL DC_IFFP ( 'SNHR' , rimnem, NRIMN, allok, + irsnhr (1) , ier ) CALL DC_IFMP ( 4, MXSNW, irsnhr, ier ) CALL DC_IFFP ( 'DOFS' , rimnem, NRIMN, allok, + irdofs (1) , ier ) CALL DC_IFMP ( 4, MXSNW, irdofs, ier ) CALL DC_IFFP ( 'DOFSQA', rimnem, NRIMN, allok, + irdofsqa (1), ier ) CALL DC_IFMP ( 4, MXSNW, irdofsqa, ier ) CALL DC_IFFP ( 'DOFSQR', rimnem, NRIMN, allok, + irdofsqr (1), ier ) CALL DC_IFMP ( 4, MXSNW, irdofsqr, ier ) CALL DC_IFFP ( 'DOFSQD', cimnem, NCIMN, allok, + icdofsqd (1), ier ) CALL DC_IFMP ( 1, MXSNW, icdofsqd, ier ) C C* Were all of the pointers properly set? C IF ( .not. allok ) THEN iret = -1 END IF C* RETURN END