C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** LDM_WRF_PL ** C************************** C C SUBROUTINE LDM_WRF_PL (IUNOUT, KEYWORD, CH_FLAG, IDIM, NPK, NPL, + PRDF, IOPTYP) C INCLUDE 'implicit_none.finc' C C Purpose: Write out plate dependent real parameter values to LDM file C C ***** 'LDM' SERVICE ROUTINE ONLY **** C C Author: John W. Campbell, June 1993 C C Arguments: C INTEGER IUNOUT CHARACTER*(*) KEYWORD INTEGER IDIM INTEGER CH_FLAG(IDIM,*) INTEGER NPK INTEGER NPL LOGICAL PRDF INTEGER IOPTYP C IUNOUT (R) Unit number for output file (see LDM_WRITE) C KEYWORD (R) Parameter name keyword (full) C CH_FLAG (R) Array of parameter changed flags C IDIM (R) First dimension of CH_FLAG array C NPK (R) Number of packs (minimum 1) C NPL (R) Number of plates C PRDF (R) Print default values unconditionally C IOPTYP (R) IOPTYP flag from LDM_WRITE routine call C C====== Parameter statements C C C====== GLOBALS: C C C====== FUNCTION TYPES: C INTEGER LENSTR C C====== LOCALS: C LOGICAL CHANGES LOGICAL TERM INTEGER ICHAN INTEGER IOP INTEGER IUN INTEGER I INTEGER J INTEGER LL INTEGER IVAL INTEGER ND INTEGER ITYP INTEGER IFLAG INTEGER IERR CHARACTER*1 VALSTR CHARACTER*1 ERRSTR CHARACTER*80 LIN CHARACTER*80 STR REAL VALUE REAL VREF REAL EP C LOGICAL CHANGES !Changed parameter values flag C LOGICAL TERM !Terminal o/p flag C INTEGER ICHAN !Changed values channel C INTEGER IOP !Output flag (see LDM_WRITE) C INTEGER IUN !Output unit no. C INTEGER I !Packs loop variable C INTEGER J !Plates loop variable C INTEGER LL !Significant length of line/string C INTEGER IVAL !Integer value of parameter C INTEGER ND !No. of decimal placed for parameter value print C INTEGER ITYP !Parameter type flag from LDM_GET C INTEGER IFLAG !Parameter value status flag from LDM_GET C INTEGER IERR !Error flag from LDM_GET C CHARACTER*1 VALSTR !Parameter value string (treated as dummy here) C CHARACTER*1 ERRSTR !Error return string (treated as dummy here) C CHARACTER*80 LIN !Buffer for output line C CHARACTER*80 STR !String for current keyword & value C REAL VALUE !Real value of parameter C REAL VREF !Reference value C REAL EP !Small difference for 'equal' values test C C------------------------------------------------------------------------------- C IF (IOPTYP.GT.0) THEN CHANGES = .FALSE. ICHAN = 0 IOP = IOPTYP ELSE CHANGES = .TRUE. ICHAN = -IOPTYP IOP = 1 IF (ICHAN.LT.1.OR.ICHAN.GT.16) RETURN END IF IF (IUNOUT.GT.0) THEN IUN = IUNOUT TERM = .FALSE. ELSE IUN = -IUNOUT TERM = .TRUE. END IF IF (IOP.EQ.4.OR.CHANGES) GO TO 700 C C====== See if same for all packs and plates C CALL LDM_GET (KEYWORD, 1, 1, VALSTR, VREF, ND, IVAL, + IFLAG, ITYP, IERR, ERRSTR) EP = 1.0E-09 DO 200 I = 1, NPK DO 150 J = 1, NPL CALL LDM_GET (KEYWORD, I, J, VALSTR, VALUE, ND, IVAL, + IFLAG, ITYP, IERR, ERRSTR) IF (ABS(VALUE-VREF).GT.EP) GO TO 300 150 CONTINUE 200 CONTINUE CALL LDM_GET (KEYWORD, 1, 1, VALSTR, VALUE, ND, IVAL, + IFLAG, ITYP, IERR, ERRSTR) IF (PRDF.OR.IFLAG.GT.0) THEN STR = KEYWORD CALL STR_ADDF (STR, VALUE, ND, 1) IF (TERM) THEN CALL TTSEND (IUN,STR(1:LENSTR(STR)),1) ELSE WRITE(IUN,1000) STR(1:LENSTR(STR)) END IF END IF RETURN C C======= See if global for plates within each pack C 300 DO 400 I = 1, NPK CALL LDM_GET (KEYWORD, I, 1, VALSTR, VREF, ND, IVAL, + IFLAG, ITYP, IERR, ERRSTR) EP = 1.0E-09 DO 350 J = 1, NPL CALL LDM_GET (KEYWORD, I, J, VALSTR, VALUE, ND, IVAL, + IFLAG, ITYP, IERR, ERRSTR) IF (ABS(VALUE-VREF).GT.EP) GO TO 500 350 CONTINUE 400 CONTINUE LIN = ' ' DO 420 I = 1, NPK CALL LDM_GET (KEYWORD, I, 1, VALSTR, VALUE, ND, IVAL, + IFLAG, ITYP, IERR, ERRSTR) STR = KEYWORD CALL STR_ADDS (STR, '[',0) CALL STR_ADDI (STR, I, 0) CALL STR_ADDS (STR, ']', 0) CALL STR_ADDF (STR, VALUE, ND, 1) CALL LDM_ADDOUT (LIN, STR, IUN, TERM) 420 CONTINUE IF (LIN.NE.' ') THEN IF (TERM) THEN CALL TTSEND (IUN,LIN(1:LENSTR(LIN)),1) ELSE WRITE(IUN,1000) LIN(1:LENSTR(LIN)) END IF END IF RETURN C C======= See if global for all packs for each plate C 500 DO 600 J = 1, NPL CALL LDM_GET (KEYWORD, 1, J, VALSTR, VREF, ND, IVAL, + IFLAG, ITYP, IERR, ERRSTR) EP = 1.0E-09 DO 550 I = 1, NPK CALL LDM_GET (KEYWORD, I, J, VALSTR, VALUE, ND, IVAL, + IFLAG, ITYP, IERR, ERRSTR) IF (ABS(VALUE-VREF).GT.EP) GO TO 700 550 CONTINUE 600 CONTINUE LIN = ' ' DO 620 I = 1, NPL CALL LDM_GET (KEYWORD, 1, I, VALSTR, VALUE, ND, IVAL, + IFLAG, ITYP, IERR, ERRSTR) STR = KEYWORD CALL STR_ADDS (STR, '[][',0) CALL STR_ADDI (STR, I, 0) CALL STR_ADDS (STR, ']', 0) CALL STR_ADDF (STR, VALUE, ND, 1) CALL LDM_ADDOUT (LIN, STR, IUN, TERM) 620 CONTINUE IF (LIN.NE.' ') THEN IF (TERM) THEN CALL TTSEND (IUN,LIN(1:LENSTR(LIN)),1) ELSE WRITE(IUN,1000) LIN(1:LENSTR(LIN)) END IF END IF RETURN C C====== No uniform pattern / output all (or changes) C 700 LIN = ' ' DO 720 I = 1, NPK DO 710 J = 1, NPL CALL LDM_GET (KEYWORD, I, J, VALSTR, VALUE, ND, IVAL, + IFLAG, ITYP, IERR, ERRSTR) IF (CHANGES) THEN CALL LDM_CHANGED (ICHAN, CH_FLAG(I,J), IFLAG) IF (IFLAG.EQ.0) GO TO 710 END IF STR = KEYWORD CALL STR_ADDS (STR, '[',0) CALL STR_ADDI (STR, I, 0) CALL STR_ADDS (STR, ']', 0) CALL STR_ADDS (STR, '[',0) CALL STR_ADDI (STR, J, 0) CALL STR_ADDS (STR, ']', 0) CALL STR_ADDF (STR, VALUE, ND, 1) CALL LDM_ADDOUT (LIN, STR, IUN, TERM) 710 CONTINUE 720 CONTINUE IF (LIN.NE.' ') THEN IF (TERM) THEN CALL TTSEND (IUN,LIN(1:LENSTR(LIN)),1) ELSE WRITE(IUN,1000) LIN(1:LENSTR(LIN)) END IF END IF RETURN C C====== Format statements C 1000 FORMAT (A) END