IAP GITLAB

oauxfi.f 5.72 KB
Newer Older
Tanguy Pierog's avatar
Tanguy Pierog committed
1 2 3
      
      SUBROUTINE OAUXFI ( FILE, IONUMB, CHSTTS, IERR )

4
#ifdef FOR_CMAKE
Tanguy Pierog's avatar
Tanguy Pierog committed
5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29
      INCLUDE '(DBLPRC)'
      INCLUDE '(DIMPAR)'
      INCLUDE '(IOUNIT)'
*
*----------------------------------------------------------------------*
*                                                                      *
*     Copyright (C) 1997-2013      by    Alfredo Ferrari & Paola Sala  *
*     All Rights Reserved.                                             *
*                                                                      *
*                                                                      *
*     Open AUXiliary FIle:                                             *
*                                                                      *
*     Created  on  30 January 1997  by   Alfredo Ferrari & Paola Sala  *
*                                              INFN - Milan            *
*                                                                      *
*     Last change  on   03-Feb-13   by     Alfredo Ferrari, INFN-Milan *
*                                                                      *
*          file   = file name                                          *
*          ionumb = logical unit number                                *
*          chstts = status word (optional, def. old)                   *
*          ierr   = error flag (output)                                *
*                                                                      *
*----------------------------------------------------------------------*
*
      INCLUDE '(COMPUT)'
30
#endif
Tanguy Pierog's avatar
Tanguy Pierog committed
31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145
*
      CHARACTER FILE*(*), CHSTTS*(*), CARD*132, FSTATS*10, FFORM*12,
     &          FACCSS*10
      LOGICAL LSCRAT, LFABRT
*
      LFABRT = IERR .NE. -1000000
      LSCRAT = .FALSE.
      IERR   = 0
*  +-------------------------------------------------------------------*
*  |  Status New:
      IF ( INDEX ( CHSTTS, 'NEW' ) .GT. 0 .OR.
     &     INDEX ( CHSTTS, 'new' ) .GT. 0 ) THEN
         FSTATS = 'NEW'
*  |
*  +-------------------------------------------------------------------*
*  |  Status Unknown:
      ELSE IF ( INDEX ( CHSTTS, 'UNKNOWN' ) .GT. 0 .OR.
     &          INDEX ( CHSTTS, 'unknown' ) .GT. 0 ) THEN
         FSTATS = 'UNKNOWN'
*  |
*  +-------------------------------------------------------------------*
*  |  Status Scratch:
      ELSE IF ( INDEX ( CHSTTS, 'SCRATCH' ) .GT. 0 .OR.
     &          INDEX ( CHSTTS, 'scratch' ) .GT. 0 ) THEN
         FSTATS = 'SCRATCH'
         LSCRAT = .TRUE.
*  |
*  +-------------------------------------------------------------------*
*  |  Status Old (default):
      ELSE
         FSTATS = 'OLD'
      END IF
*  |
*  +-------------------------------------------------------------------*
*  +-------------------------------------------------------------------*
*  |  Form Unformatted:
      IF ( INDEX ( CHSTTS, 'UNFORMATTED' ) .GT. 0 .OR.
     &     INDEX ( CHSTTS, 'unformatted' ) .GT. 0 ) THEN
         FFORM  = 'UNFORMATTED'
*  |
*  +-------------------------------------------------------------------*
*  |  Form Formatted:
      ELSE
         FFORM  = 'FORMATTED'
      END IF
*  |
*  +-------------------------------------------------------------------*
*  +-------------------------------------------------------------------*
*  |  Access direct:
      IF ( INDEX ( CHSTTS, 'DIRECT' ) .GT. 0 .OR.
     &     INDEX ( CHSTTS, 'direct' ) .GT. 0 ) THEN
         FACCSS = 'DIRECT'
*  |
*  +-------------------------------------------------------------------*
*  |  Access append:
      ELSE IF ( INDEX ( CHSTTS, 'APPEND' ) .GT. 0 .OR.
     &     INDEX ( CHSTTS, 'append' ) .GT. 0 ) THEN
         FACCSS = 'APPEND'
*  |
*  +-------------------------------------------------------------------*
*  |  Access sequential:
      ELSE
         FACCSS = 'SEQUENTIAL'
      END IF
*  |
*  +-------------------------------------------------------------------*
      IF ( .NOT. LSCRAT ) THEN
!          LQ   = MIN ( LNNBLN (FILE), 132 )
         CARD (1:LQ) = FILE (1:LQ)
      END IF
*  First of all: try to open the file in the current directory:
      IF ( LSCRAT ) THEN
         OPEN ( UNIT   = IONUMB,
     &          STATUS = FSTATS, FORM = FFORM , ACCESS = FACCSS,
     &          ERR    = 4000 )
      ELSE
         OPEN ( UNIT   = IONUMB, FILE = CARD (1:LQ),
     &          STATUS = FSTATS, FORM = FFORM , ACCESS = FACCSS,
     &          ERR    = 1000 )
      END IF
      RETURN
 1000 CONTINUE
*  Second attempt: try to open the file in the original work directory:
      OPEN ( UNIT   = IONUMB, FILE = PWDDIR (1:KPWDIR) // CARD (1:LQ),
     &       STATUS = FSTATS, FORM = FFORM , ACCESS = FACCSS,
     &       ERR    = 2000 )
      RETURN
 2000 CONTINUE
*  Third attempt: try to open the file in the FLUKA directory:
      OPEN ( UNIT   = IONUMB, FILE = HFLDIR (1:KFLDIR) // CARD (1:LQ),
     &       STATUS = FSTATS, FORM = FFORM , ACCESS = FACCSS,
     &       ERR    = 3000 )
      RETURN
 3000 CONTINUE
*  Last attempt: try to open the file in the user home directory:
      OPEN ( UNIT   = IONUMB, FILE = HOMDIR (1:KHMDIR) // CARD (1:LQ),
     &       STATUS = FSTATS, FORM = FFORM , ACCESS = FACCSS,
     &       ERR    = 4000 )
      RETURN
 4000 CONTINUE
*  +-------------------------------------------------------------------*
*  |  File opening was supposed to succeed (Lfabrt=.False. means the
*  |  file coud be or could be not exist, both acceptable)
      IF ( LFABRT ) THEN
         WRITE (LUNOUT,5000) CARD(1:LQ), IONUMB
 5000    FORMAT (' *** Impossible to open file ***',/,1X,A,/,
     &           ' *** on unit ',I4,' ***' )
! D        CALL FLABRT ( 'OAUXFI', 'IMPOSSIBLE TO OPEN FILE' )
      END IF
*  |
*  +-------------------------------------------------------------------*
      IERR = 1
      RETURN
*== End of subroutine Oauxfi ==========================================*
      END