1 subroutine OPTCHK(INTCHK, IOPT, ETEXT) 2c Copyright (c) 1996 California Institute of Technology, Pasadena, CA. 3c ALL RIGHTS RESERVED. 4c Based on Government Sponsored Research NAS7-03001. 5c>> 1998-11-01 OPTCHK Krogh ERRSEV => MACT(2) for "mangle". 6c>> 1996-05-13 OPTCHK Krogh Changes to use .C. and C%%. 7C>> 1995-03-10 OPTCHK Krogh Added "abs(.) just below "do 140 ..." 8C>> 1994-11-11 OPTCHK Krogh Declared all vars. 9c>> 1993-05-17 OPTCHK Krogh Additions for Conversion to C. 10c>> 1991-11-25 OPTCHK Krogh More comments, little clean up of code. 11c>> 1991-10-09 OPTCHK Krogh More comments, little clean up of code. 12c>> 1991-06-27 OPTCHK Krogh Initial Code. 13c 14c OPTCHK -- Fred T. Krogh, Jet Propulsion Lab., Pasadena, CA. 15c This subroutine is intended for the use of other library routines. 16c It is used to check the storage used by options for some array. 17c 18c INTCHK is an array that provides information on how storage has been 19c allocated. Information is provided in groups of three words, after 20c an initial group of 4 that contain: 21c 0. INTCHK(0) / 10 is the index to use for error messages, and 22c mod(INTCHK(0), 10) defines actions as follows: 23c Value Action on Errors Action if no errors 24c 0 Prints & Stops Returns 25c 1 Prints & Returns Returns 26c 2 Prints & Stops Prints & Returns 27c 3 Prints & Returns Prints & Returns 28c >3 Any error message will be continued, subtract 4 from the 29c value to get one of the actions above. 30c 1. Contains LAST, 1 more than the index of the last location in 31c INTCHK used to store the information as described below. 32c 2. The amount of storage available in the array being checked. If 33c this is 0, it is assumed that the user would like to know what 34c size to declare for the array, and if it is -1, it is assumed 35c that a library routine is doing the check without knowing what 36c the declared size is. 37c 3. The amount of storage required in this array if no options were 38c used. (This + 1 is first loc. available for option storage.) 39c The rest should be set as follows, for k = 5, LAST, 3: 40c k-1 Option index, 0 indicates storage required by default. (This 41c may depend on input parameters, but doesn't depend explicitly 42c on an option.) 43c k If >0, gives the start of space used by the option. 44c If <0, gives -(amount of space required by an option), for 45c which a starting location is to be determined. 46c k+1 If preceding entry is >0, gives space required by the option. 47c Else it is assumed that the space requested is to be found, 48c and a diagnostic will be given if space can not be found. Else 49c INTCHK(K+1) IOPT(INTCHK(k+1)) Diagnostic on successful alloc.? 50c 0 ---- No 51c <0 ---- Yes 52c >0 .ne. -1 Yes 53c >0 .eq. -1 No, and IOPT(INTCHK(k+1)) is set 54c to starting loc. of space found. 55c When this program finds the space for an option, values of 56c INTCHK(j) for j .ge. LAST will be used. INTCHK(k+1) is set 57c temporarily to -(space required) and INTCHK(k-1) is reduced by 58c 2000000 to flag the fact that the location index must be saved 59c after INTCHK(LAST). INTCHK(LAST) is assumed to contain 1 if 60c the largest space requested is required, and to contain 61c -(minimal space needed) if the large amount requested is not 62c essential. 63c On exit, INTCHK(1) is set = -LAST if there was some kind of error. 64c (Unless the user has called MESS this return can't happen.) 65c INTCHK(2) is set to suggest a value for the storage to be declared. 66c The remaining locations are changed as follows: 67c k-1 Negated if there was a problem with this option, or if the 68c following location was initially <0. 69c k Starting location used or suggested for the option. 70c k+1 Last location used or suggested for the option. 71c 72c In addition if values of INTCHK(j) for j .ge. LAST are used, 73c INTCHK(j), for j = LAST+1, LAST+2, ..., will be set so that 74c INTCHK(j) is equal to (one of the k's above) - 1 for an option 75c that has had a starting location assigned, and INTCHK(LAST) is 76c set to the last index value for j in the above list. 77c 78c IOPT This is stored to if INTCHK(k) is < 0, see above. 79c ETEXT Input text of the form 'Package_name / Argument_name$E'. Thus 80c for argument KORD of the package DIVA, this would = 'DIVA / KORD$E'. 81c 82c ************************** Variable definitions ********************** 83c 84c ERRBAD Flag to use for error severity if get an error. 17 if errors 85c are to print but not stop, 57 otherwise. 86c ETEXT (Input) Used to construct error messages, see above. 87c I Induction variable for accessing INTCHK(). 88c INTCHK (InOut) See above. 89c IOPT (Out) If space information is being obtained results are saved 90c here. See above. 91c ISTRT Starting index for placing options with unknown locations. 92c KEX Points to the last place in INTCHK where indices of entries 93c that have had locations determined here are stored. 94c L Temporary index. 95c LAST First free location in INTCHK. (=INTCHK(1)) 96c LNEG Index of the first INTCHK entry that is to be positioned. 97c LOPT Location in IOPT to get location of INTCHK entry that is 98c positioned. 99c LTXTAx Variables setup by PMESS defining the locations in MTXTAA where 100c various error messages start. 101c LTXTEE Location in MTXTAA where data in ETEXT is stored. 102c LTXTZZ Number of characters available for saving ETEXT in MTXTAA. 103c LWANT -Number of locations wanted by INTCHK entry being positioned. 104c MACT Vector used to specify error printing actions, see MESS. 105c MACT(2) flags error/diagnostic level. = 0 none; 07 is used to 106C get diagnostics only; and ERRBAD otherwise. 107c MEEMES Parameter specifying that error message is to be printed. 108c MEIDAT Parameter specifying location in INTCHK to start printing 109c integer in MESS. 110c MEIMAT Parameter specifying an integer matrix is to be printed. 111c MENTXT Parameter specifying location in INTCHK to start printing 112c text from MTXTAA in MESS. 113c MERET Parameter specifying the end of an error message. 114c MESS Routine to print error and diagnostc messages. 115c METEXT Parameter specifying that text is to be printed. 116c MI Temporary index used to save in acceptable location. 117c MTXTAA Used to contain error message text and instructions, see MESS. 118c MTXTAx Character variables setup by PMESS and equivalenced into ETEXT 119c used to contain parts of the error messages. 120c MTXTZZ As for MTXTAx, except not setup by PMESS. Used to hold text 121c from ETEXT. 122c MV Temporary, which contains value associated with INTCHK(MI). 123c N Temporary value. 124c NERBAD Array telling what to do concerning errrors. ERRBAD is set 125c from NERBAD(mod(INTCHK(0), 10)), and the default value for 126c MACT(2) is set from NERBAD(INTCHK(0)+4). 127c 128c ************************** Variable Declarations ********************* 129c 130 integer INTCHK(0:*), IOPT(*) 131 character ETEXT*(*) 132 integer I, ISTRT, KEX, L, LAST, LNEG, LOPT, LWANT, MI, MV, N 133c Declarations for error messages. 134 integer MENTXT, MEIDAT, MECONT, MERET, MEEMES, METEXT, MEIMAT, 135 1 LTXTEE, LTXEND 136 parameter (MENTXT =23) 137 parameter (MEIDAT =24) 138 parameter (MECONT =50) 139 parameter (MERET =51) 140 parameter (MEEMES =52) 141 parameter (METEXT =53) 142 parameter (MEIMAT =58) 143 integer MACT(16), ERRBAD, NERBAD(0:7) 144c 145c ********* Error message text *************** 146c[Last 2 letters of Param. name] [Text generating message.] 147cAA OPTCHK$B 148cAB "Option #" is negated if option needs attention.$N 149c "Option 0" is for space not associated with a specific option.$N 150c "First Loc." is negated if user did not set value.$N 151c Space avail. = $I; all options must have first loc. > $I$E 152cAC Option #$HFirst Loc.$HLast Loc.$E 153cAD From subprogram/argument: $B 154cAE Space for ETEXT.$E 155 integer LTXTAA,LTXTAB,LTXTAC,LTXTAD,LTXTAE 156 parameter (LTXTAA= 1,LTXTAB= 9,LTXTAC=233,LTXTAD=267,LTXTAE=295) 157 character MTXTAA(2) * (156) 158c Next 4 lines not automatically generated 159c%% #define LTXTEE 137 160 parameter (LTXTEE = LTXTAE - 156 - 2) 161 parameter (LTXEND = 156) 162C 163 data MTXTAA/'OPTCHK$B"Option #" is negated if option needs attenti 164 *on.$N"Option 0" is for space not associated with a specific option 165 *.$N"First Loc." is negated if user di','d not set value.$NSpace av 166 *ail. = $I; all options must have first loc. > $I$EOption #$HFirst$ 167 * Loc.$HLast Loc.$EFrom subprogram/argument: $BSpace for ETEXT.$E'/ 168c 169c 1 2 3 4 5 6 7 8 9 170 data MACT / MEEMES,0,1,LTXTAD, MEIDAT, 2, MENTXT,LTXTAB, METEXT, 171 1 MEIMAT,3,3,0,LTXTAC,-1, MERET / 172c 10 13 14 15 16 173 data NERBAD / 57, 17, 57, 17, 0, 0, 7, 7 / 174c 175c *************************** Start of Executable Code ***************** 176c 177 MACT(3) = INTCHK(0) / 10 178 MACT(16)=MERET 179 I = INTCHK(0) - 10*MACT(3) 180 if (I .gt. 3) then 181 I = I - 4 182 MACT(16) = MECONT 183 end if 184 ERRBAD = NERBAD(I) 185 MACT(2) = NERBAD(I+4) 186 LAST = INTCHK(1) 187 KEX = LAST 188 20 LNEG = 0 189 do 100 I = 5, LAST, 3 190c Loop to sort on the low indices -- Inefficient algorithm to keep 191c code short -- LAST should never be very big. 192 MI = I 193 MV = INTCHK(I) 194 do 50 L = I+3, LAST, 3 195c Find mimimum from here down. 196 if (INTCHK(L) .lt. MV) then 197 MI = L 198 MV = INTCHK(L) 199 end if 200 50 continue 201 if (MI .ne. I) then 202c Interchange to get low at top. 203 do 70 L = -1, 1 204 N = INTCHK(I+L) 205 INTCHK(I+L) = INTCHK(MI+L) 206 INTCHK(MI+L) = N 207 70 continue 208 end if 209 if (MV .lt. 0) then 210c Save loc. of last entry that needs space to be found. 211 LNEG = I 212 else if (LNEG .eq. 0) then 213c Entry I and previous entries are in their correct sorted order. 214 if (INTCHK(I+1) .lt. 0) then 215 if (INTCHK(I-1) .lt. -1000000) then 216 INTCHK(I-1) = INTCHK(I-1) + 2000000 217 INTCHK(I+1) = -INTCHK(I+1) 218c Save INTCHK index defining allocated space. 219 KEX = KEX + 1 220 INTCHK(KEX) = I - 1 221 else 222c Error -- Got request for a negative amount of space. 223 MACT(2) = ERRBAD 224 INTCHK(I-1) = -abs(INTCHK(I-1)) 225 end if 226 end if 227c Save final location used by the option. 228 INTCHK(I+1) = INTCHK(I) + INTCHK(I+1) - 1 229 if (INTCHK(I) .le. INTCHK(I-2)) then 230c Error -- options overlap. 231 INTCHK(I-1) = -abs(INTCHK(I-1)) 232 MACT(2) = ERRBAD 233 end if 234 end if 235 100 continue 236 if (LNEG .ne. 0) then 237c Find spaces that need to be allocated, starting with the smallest. 238 ISTRT = LNEG 239 I = LNEG 240 120 LWANT = INTCHK(LNEG) 241 LOPT = INTCHK(LNEG+1) 242 if (I .eq. LNEG) then 243c Make fake entry to get started. 244 INTCHK(LNEG) = 1 245 INTCHK(LNEG+1) = INTCHK(3) 246 end if 247 do 140 ISTRT = ISTRT, LAST-3, 3 248 if(INTCHK(I)+abs(INTCHK(I+1))-LWANT .lt. INTCHK(ISTRT+3)) 249 1 go to 150 250 I = ISTRT + 3 251 140 continue 252 150 INTCHK(LNEG) = INTCHK(I) + abs(INTCHK(I+1)) 253 if (LOPT .ne. 0) then 254 if (LOPT .gt. 0) then 255 if (IOPT(LOPT) .eq. -1) then 256 IOPT(LOPT) = INTCHK(LNEG) 257 go to 160 258 end if 259 end if 260c Error -- IOPT not expecting starting loc. 261 INTCHK(LNEG-1) = -abs(INTCHK(LNEG-1)) 262 MACT(2) = ERRBAD 263 end if 264 160 INTCHK(LNEG+1) = LWANT 265 INTCHK(LNEG-1) = INTCHK(LNEG-1) - 2000000 266 if (LNEG .lt. 8) go to 20 267 I = LNEG 268 LNEG = LNEG - 3 269 go to 120 270 end if 271 if (INTCHK(LAST-1) .gt. INTCHK(2)) then 272 if (INTCHK(2) .lt. 0) go to 180 273 if (LAST .ne. KEX) then 274 if (INTCHK(KEX) .eq. LAST - 3) then 275 if (INTCHK(LAST) .le. 0) then 276 if (INTCHK(LAST-2)-INTCHK(LAST)-1 .le. INTCHK(2)) then 277 INTCHK(LAST-1) = INTCHK(2) 278 go to 180 279 end if 280 end if 281 end if 282 end if 283 INTCHK(LAST-3) = -abs(INTCHK(LAST-3)) 284 MACT(2) = ERRBAD 285 end if 286 180 if (LAST .ne. KEX) INTCHK(LAST) = KEX 287 if (MACT(2) .gt. 0) then 288 190 if (LAST .ne. KEX) then 289 do 200 I = LAST+1, abs(KEX) 290 INTCHK(INTCHK(I)+1) = -INTCHK(INTCHK(I)+1) 291 200 continue 292 if (KEX .lt. 0) go to 210 293 KEX = -KEX 294 end if 295 MACT(13) = (LAST - 4) / 3 296c%% strcpy(&mtxtaa[1][LTXTEE-1], etext); 297 MTXTAA(2)(LTXTEE:LTXEND)=ETEXT(1:) 298 call MESS(MACT, MTXTAA, INTCHK(1)) 299 if (MACT(2) .gt. 10) INTCHK(1) = -LAST 300 if (LAST .ne. KEX) go to 190 301 end if 302 210 INTCHK(2) = INTCHK(LAST-1) 303 return 304 end 305