code.delx.au - gnu-emacs/blob - test/manual/etags/f-src/entry.for

   1 C$Procedure      PRTPKG ( Declare Arguments for Error Message Routines )
   2
   3       LOGICAL FUNCTION PRTPKG ( SHORT, LONG, EXPL, TRACE, DFAULT, TYPE )
   4
   5 C$ Abstract
   6 C
   7 C      Declare the arguments for the error message selection entry
   8 C      points.  DO NOT CALL THIS ROUTINE.
   9 C
  10 C$ Required_Reading
  11 C
  12 C      ERROR
  13 C
  14 C$ Keywords
  15 C
  16 C      ERROR
  17 C
  18 C$ Declarations
  19
  20        LOGICAL               SHORT
  21        LOGICAL               EXPL
  22        LOGICAL               LONG
  23        LOGICAL               TRACE
  24        LOGICAL               DFAULT
  25        CHARACTER*(*)         TYPE
  26
  27        INTEGER               FILEN
  28        PARAMETER           ( FILEN = 128 )
  29
  30
  31 C$ Brief_I/O
  32 C
  33 C      VARIABLE  I/O  ENTRY
  34 C      --------  ---  --------------------------------------------------
  35 C
  36 C      SHORT      I   SETPRT
  37 C      EXPL       I   SETPRT
  38 C      LONG       I   SETPRT
  39 C      TRACE      I   SETPRT
  40 C      DFAULT     I   SETPRT
  41 C      TYPE       I   MSGSEL
  42 C      FILEN      P   MSGSEL
  43 C
  44 C$ Detailed_Input
  45 C
  46 C      See the ENTRY points for discussions of their arguments.
  47 C
  48 C$ Detailed_Output
  49 C
  50 C      See the ENTRY points for discussions of their arguments.
  51 C
  52 C$ Parameters
  53 C
  54 C      See the ENTRY points for discussions of their parameters.
  55 C
  56 C$ Exceptions
  57 C
  58 C      This routine signals an error IF IT IS CALLED.
  59 C
  60 C$ Files
  61 C
  62 C      None.
  63 C
  64 C$ Particulars
  65 C
  66 C      DO NOT CALL THIS ROUTINE.
  67 C
  68 C      The entry points declared in this routine are:
  69 C
  70 C      SETPRT
  71 C      MSGSEL
  72 C
  73 C      There is no reason to call this subroutine.
  74 C      The purpose of this subroutine is to make the
  75 C      declarations required by the various entry points.
  76 C      This routine has no run-time function.
  77 C
  78 C$ Examples
  79 C
  80 C      None.  DO NOT CALL THIS ROUTINE.
  81 C
  82 C$ Restrictions
  83 C
  84 C      DO NOT CALL THIS ROUTINE.
  85 C
  86 C$ Literature_References
  87 C
  88 C      None.
  89 C
  90 C$ Author_and_Institution
  91 C
  92 C
  93 C$ Version
  94 C
  95 C-
  96 C         Comment section for permuted index source lines was added
  97 C         following the header.
  98 C
  99 C
 100 C-&
 101
 102 C$ Index_Entries
 103 C
 104 C     None.
 105 C
 106 C-&
 107
 108
 109
 110 C$ Revisions
 111 C
 112 C
 113 C-     Beta Version 1.0.1, 08-FEB-1989
 114 C
 115 C         PRTPKG, though it performs no run-time function, must
 116 C         still return a value, in order to comply with the Fortran
 117 C         standard.  So, now it does.
 118 C
 119 C-     Beta Version 1.0.1, 08-FEB-1989
 120 C
 121 C         Warnings added to discourage use of this routine.
 122 C         Parameter declarations moved to "Declarations" section.
 123 C         Two local declarations moved to the correct location.
 124 C-&
 125
 126
 127
 128 C
 129 C     SPICELIB functions
 130 C
 131
 132       LOGICAL               SETPRT
 133       LOGICAL               MSGSEL
 134
 135 C
 136 C     Local variables:
 137 C
 138       CHARACTER*(FILEN)     DEVICE
 139
 140       CHARACTER*(10)        LTYPE
 141       CHARACTER*(10)        LOCTYP
 142
 143 C
 144 C     Saved variables:
 145 C
 146       LOGICAL               SVSHRT
 147       LOGICAL               SVEXPL
 148       LOGICAL               SVLONG
 149       LOGICAL               SVTRAC
 150       LOGICAL               SVDFLT
 151
 152       SAVE                  SVSHRT
 153       SAVE                  SVEXPL
 154       SAVE                  SVLONG
 155       SAVE                  SVTRAC
 156       SAVE                  SVDFLT
 157
 158 C
 159 C     Initial values:
 160 C
 161       DATA     SVSHRT   / .TRUE. /
 162       DATA     SVEXPL   / .TRUE. /
 163       DATA     SVLONG   / .TRUE. /
 164       DATA     SVTRAC   / .TRUE. /
 165       DATA     SVDFLT   / .TRUE. /
 166
 167 C
 168 C     Executable Code:
 169 C
 170
 171       CALL GETDEV ( DEVICE )
 172
 173       CALL WRLINE ( DEVICE,
 174      .              'PRTPKG:  You have called an entry point which' //
 175      .              ' has no run-time function; this may indicate'  //
 176      .              ' a program bug.  Please check the PRTPKG'      //
 177      .              ' documentation.  ' )
 178
 179       CALL WRLINE ( DEVICE, 'SPICE(BOGUSENTRY)' )
 180
 181       PRTPKG = .FALSE.
 182
 183       RETURN
 184
 185
 186
 187
 188
 189
 190 C$Procedure      SETPRT ( Store Error Message Types to be Output )
 191
 192 C      ENTRY  BOGUS (X, Y, Z)
 193
 194        ENTRY  SETPRT ( SHORT, EXPL, LONG, TRACE, DFAULT )
 195
 196 C$ Abstract
 197 C
 198 C      Store (a representation of) the selection of types of error
 199 C      messages to be output.  DO NOT CALL THIS ROUTINE.
 200 C
 201 C$ Required_Reading
 202 C
 203 C      ERROR
 204 C
 205 C$ Keywords
 206 C
 207 C      ERROR
 208 C
 209 C$ Declarations
 210 C
 211 C      LOGICAL               SHORT
 212 C      LOGICAL               EXPL
 213 C      LOGICAL               LONG
 214 C      LOGICAL               TRACE
 215 C      LOGICAL               DFAULT
 216 C
 217 C$ Brief_I/O
 218 C
 219 C      VARIABLE  I/O  DESCRIPTION
 220 C      --------  ---  --------------------------------------------------
 221 C
 222 C      SHORT      I   Select output of short error message?
 223 C      EXPL       I   Select output of explanation of short message?
 224 C      LONG       I   Select output of long error message?
 225 C      TRACE      I   Select output of traceback?
 226 C      DFAULT     I   Select output of default message?
 227 C
 228 C$ Detailed_Input
 229 C
 230 C      SHORT    indicates whether the short error message is selected
 231 C               as one of the error messages to be output when an error
 232 C               is detected.  A value of .TRUE. indicates that the
 233 C               short error message IS selected.
 234 C
 235 C      EXPL     indicates whether the explanatory text for the short
 236 C               error message is selected as one of the error messages
 237 C               to be output when an error is detected.  A value of
 238 C               .TRUE. indicates that the explanatory text for the
 239 C               short error message IS selected.
 240 C
 241 C      LONG     indicates whether the long error message is selected
 242 C               as one of the error messages to be output when an error
 243 C               is detected.  A value of .TRUE. indicates that the
 244 C               long error message IS selected.
 245 C
 246 C      TRACE    indicates whether the traceback is selected
 247 C               as one of the error messages to be output when an error
 248 C               is detected.  A value of .TRUE. indicates that the
 249 C               traceback IS selected.
 250 C
 251 C      DFAULT   indicates whether the default message is selected
 252 C               as one of the error messages to be output when an error
 253 C               is detected.  A value of .TRUE. indicates that the
 254 C               default message IS selected.
 255 C
 256 C
 257 C$ Detailed_Output
 258 C
 259 C      None.
 260 C
 261 C$ Parameters
 262 C
 263 C      None.
 264 C
 265 C$ Exceptions
 266 C
 267 C      None.
 268 C
 269 C$ Files
 270 C
 271 C      None.
 272 C
 273 C$ Particulars
 274 C
 275 C      DO NOT CALL THIS ROUTINE.
 276 C
 277 C      The effect of this routine is an ENVIRONMENTAL one.  This
 278 C      routine performs no output;  it stores the error message
 279 C      selection provided as input.
 280 C
 281 C      Note that the actual output of error messages depends not
 282 C      only on the selection made using this routine, but also
 283 C      on the selection of the error output device (see ERRDEV)
 284 C      and the choice of error response action (see ERRACT). If
 285 C      the action is not 'IGNORE' (possible choices are
 286 C      'IGNORE', 'ABORT', 'DEFAULT', 'REPORT', and 'RETURN'),
 287 C      the selected error messages will be written to the chosen
 288 C      output device when an error is detected.
 289 C
 290 C$ Examples
 291 C
 292 C      1.  In this example, the short and long messages are selected.
 293 C
 294 C      C
 295 C      C     Select short and long error messages for output
 296 C      C     (We don't examine the status returned because no
 297 C      C     errors are detected by SETPRT):
 298 C      C
 299 C
 300 C            STATUS = SETPRT ( .TRUE., .FALSE., .TRUE., .FALSE.,
 301 C           .                  .FALSE.                          )
 302 C
 303 C
 304 C
 305 C$ Restrictions
 306 C
 307 C      DO NOT CALL THIS ROUTINE.
 308 C
 309 C$ Literature_References
 310 C
 311 C      None.
 312 C
 313 C$ Author_and_Institution
 314 C
 315 C
 316 C$ Version
 317 C
 318 C-
 319 C
 320 C-&
 321
 322 C$ Index_Entries
 323 C
 324 C     None.
 325 C
 326 C-&
 327
 328
 329 C$ Revisions
 330 C
 331 C-
 332 C         Warnings added to discourage use of this routine in
 333 C         non-error-handling code.  Parameters section added.
 334 C
 335 C-&
 336
 337
 338
 339 C
 340 C     Executable Code:
 341 C
 342
 343
 344       IF   (  SHORT  )    THEN
 345          SVSHRT = .TRUE.
 346       ELSE
 347          SVSHRT = .FALSE.
 348       END IF
 349
 350
 351
 352       IF   (  EXPL   )    THEN
 353          SVEXPL = .TRUE.
 354       ELSE
 355          SVEXPL = .FALSE.
 356       END IF
 357
 358
 359
 360       IF   (  LONG   )    THEN
 361          SVLONG = .TRUE.
 362       ELSE
 363          SVLONG = .FALSE.
 364       END IF
 365
 366
 367
 368       IF   (  TRACE  )    THEN
 369          SVTRAC = .TRUE.
 370       ELSE
 371          SVTRAC = .FALSE.
 372       END IF
 373
 374       IF   (  DFAULT  )    THEN
 375          SVDFLT = .TRUE.
 376       ELSE
 377          SVDFLT = .FALSE.
 378       END IF
 379
 380
 381 C
 382 C     We assign a value to SETPRT, but this value is
 383 C     not meaningful...
 384 C
 385       SETPRT = .TRUE.
 386
 387
 388       RETURN
 389
 390
 391
 392
 393 C$Procedure      MSGSEL  ( Is This Message Type Selected for Output? )
 394
 395        ENTRY  MSGSEL ( TYPE )
 396
 397 C$ Abstract
 398 C
 399 C      Indicate whether the specified message type has been selected
 400 C      for output.
 401 C
 402 C$ Required_Reading
 403 C
 404 C      ERROR
 405 C
 406 C$ Keywords
 407 C
 408 C      ERROR
 409 C
 410 C$ Declarations
 411 C
 412 C      TYPE
 413 C
 414 C$ Brief_I/O
 415 C
 416 C      VARIABLE  I/O  DESCRIPTION
 417 C      --------  ---  --------------------------------------------------
 418 C
 419 C      TYPE       I   Type of message whose selection status is queried.
 420 C      FILEN      P   Maximum length of a file name.
 421 C
 422 C      The function takes the value .TRUE. if the message type indicated
 423 C      by TYPE has been selected for output to the error output device.
 424 C
 425 C
 426 C$ Detailed_Input
 427 C
 428 C      TYPE   Refers to a type of error message.  Possible values
 429 C             are 'SHORT', 'EXPLAIN', 'LONG', 'DEFAULT',
 430 C             and 'TRACEBACK'.
 431 C
 432 C$ Detailed_Output
 433 C
 434 C      The function takes the value .TRUE. if the message type indicated
 435 C      by TYPE has been selected for output to the error output device.
 436 C
 437 C$ Parameters
 438 C
 439 C      FILEN  is the maximum length of a file name.
 440 C
 441 C$ Exceptions
 442 C
 443 C      Additionally, invalid values of TYPE are detected.
 444 C
 445 C      The short error message set in this case is:
 446 C      'SPICE(INVALIDMSGTYPE)'
 447 C
 448 C      The handling of this error is a special case; to avoid recursion
 449 C      problems, SIGERR is not called when the error is detected.
 450 C      Instead, the short and long error messages are output directly.
 451 C
 452 C
 453 C$ Files
 454 C
 455 C      None.
 456 C
 457 C$ Particulars
 458 C
 459 C      This routine is part of the SPICELIB error handling mechanism.
 460 C
 461 C      Note that even though a given type of message may have been
 462 C      selected for output, the output device and error response
 463 C      action must also have been selected appropriately.
 464 C      Use ERRDEV to choose the output device for error messages.
 465 C      Use ERRACT to choose the error response action.  Any action
 466 C      other than 'IGNORE' will result in error messages being
 467 C      written to the error output device when errors are detected.
 468 C      See ERRACT for details.
 469 C
 470 C$ Examples
 471 C
 472 C
 473 C      1.  We want to know if the short message has been selected
 474 C          for output:
 475 C
 476 C          C
 477 C          C     Test whether the short message has been selected:
 478 C          C
 479 C
 480 C                SELECT = MSGSEL ( 'SHORT' )
 481 C
 482 C
 483 C$ Restrictions
 484 C
 485 C      None.
 486 C
 487 C$ Literature_References
 488 C
 489 C      None.
 490 C
 491 C$ Author_and_Institution
 492 C
 493 C
 494 C$ Version
 495 C
 496 C
 497 C-&
 498
 499 C$ Index_Entries
 500 C
 501 C     None.
 502 C
 503 C-&
 504
 505
 506 C$ Revisions
 507 C
 508 C
 509 C         Parameters section added; parameter declaration added
 510 C         to brief I/O section as well.
 511 C
 512 C-&
 513
 514
 515
 516 C
 517 C     Executable Code:
 518 C
 519
 520       CALL LJUST ( TYPE,  LTYPE )
 521       CALL UCASE ( LTYPE, LTYPE )
 522
 523
 524       IF ( LTYPE  .EQ. 'SHORT' ) THEN
 525
 526          MSGSEL = SVSHRT
 527
 528       ELSE IF ( LTYPE  .EQ. 'EXPLAIN' ) THEN
 529
 530          MSGSEL = SVEXPL
 531
 532       ELSE IF ( LTYPE  .EQ. 'LONG' ) THEN
 533
 534          MSGSEL = SVLONG
 535
 536       ELSE IF ( LTYPE  .EQ. 'TRACEBACK' ) THEN
 537
 538          MSGSEL = SVTRAC
 539
 540       ELSE IF ( LTYPE  .EQ. 'DEFAULT' ) THEN
 541
 542          MSGSEL = SVDFLT
 543
 544       ELSE
 545
 546 C
 547 C        Bad value of type!  We have a special case here; to
 548 C        avoid recursion, we output the messages directly,
 549 C        rather than call SIGERR.
 550 C
 551
 552          CALL GETDEV ( DEVICE )
 553
 554          CALL WRLINE ( DEVICE,  'SPICE(INVALIDMSGTYPE)' )
 555
 556          CALL WRLINE ( DEVICE, ' ' )
 557
 558          LOCTYP = TYPE
 559
 560 C
 561 C        Note:  What looks like a typo below isn't; there's
 562 C        a line break after the substring 'specified' of
 563 C        the "word" 'specifiedwas'.
 564 C
 565
 566          CALL WRLINE ( DEVICE,
 567
 568      .   'MSGSEL:  An invalid error message type was supplied as'     //
 569      .   ' input; the type specifiedwas:  ' // LOCTYP
 570
 571      .                )
 572
 573
 574       END IF
 575
 576        subroutine
 577      & intensity1(efv,fv,svin,svquad,sfpv,maxp,value,jndex,k,kj,jmod,isup)
 578
 579        character*(*) function foo()
 580
 581       END