Initial commit from Polytechnique Montreal

1 files changed, 90 insertions, 0 deletions

diff --git a/Dragon/src/AEXDIR.f b/Dragon/src/AEXDIR.f
new file mode 100644
index 0000000..d8f6897
--- /dev/null
+++ b/Dragon/src/AEXDIR.f
@@ -0,0 +1,90 @@
+*DECK AEXDIR
+      SUBROUTINE AEXDIR (NFICH,LBLOC,DATA,IADRES,LGSEG)
+*
+*-----------------------------------------------------------------------
+*
+*Purpose:
+* Read infomation from a direct access file. Component of a FORTRAN-77
+* emulator of the SAPHYR archive system.
+*
+*Copyright:
+* Copyright (C) 1999 Ecole Polytechnique de Montreal
+* This library is free software; you can redistribute it and/or
+* modify it under the terms of the GNU Lesser General Public
+* License as published by the Free Software Foundation; either
+* version 2.1 of the License, or (at your option) any later version
+*
+*Author(s): A. Hebert
+*
+*Parameters: input
+* NFICH   unit number of the direct access file.
+* LBLOC   direct access buffer length.
+* IADRES  offset, from start of file where data is extracted from
+*         or where data is to be stored.
+* LGSEG   number of words to read from or write into file.
+*
+*Parameters: output
+* DATA    address in memory where data is to be moved or extracted.
+*
+*-----------------------------------------------------------------------
+*
+      IMPLICIT INTEGER(A-Z)
+      INTEGER DATA(LGSEG),LNEWAD(2)
+      INTEGER, ALLOCATABLE, DIMENSION(:) :: WRK
+*
+      ALLOCATE(WRK(LBLOC))
+      INDEX=IADRES
+      ID=0
+      NROLD=0
+   10 NREC=1+INDEX/LBLOC
+      N=MOD(INDEX,LBLOC)
+      LMIN=1
+   20 IF(NREC.NE.NROLD) THEN
+*       --------------------------------------------------------
+        READ(NFICH,REC=NREC,ERR=90,IOSTAT=IR) (WRK(I),I=1,LBLOC)
+*       --------------------------------------------------------
+        NROLD=NREC
+      ENDIF
+      NGRO=MIN(LBLOC+LMIN-N-1,2)
+      DO 30 L=LMIN,NGRO
+      N=N+1
+      LNEWAD(L)=WRK(N)
+   30 CONTINUE
+      IF(NGRO.EQ.2) GO TO 40
+      NREC=NREC+1
+      N=0
+      LMIN=NGRO+1
+      GO TO 20
+   40 LINFO=LNEWAD(2)
+      IF(ID+LINFO.GT.LGSEG) CALL XABORT('AEXDIR: DIRECT ACCESS READ FA'
+     1 //'ILURE(1).')
+      NREC=1+(INDEX+2)/LBLOC
+      N=MOD(INDEX+2,LBLOC)
+      LMIN=1
+   50 IF(NREC.NE.NROLD) THEN
+*       --------------------------------------------------------
+        READ(NFICH,REC=NREC,ERR=90,IOSTAT=IR) (WRK(I),I=1,LBLOC)
+*       --------------------------------------------------------
+        NROLD=NREC
+      ENDIF
+      NGRO=MIN(LBLOC+LMIN-N-1,LINFO)
+      DO 60 L=LMIN,NGRO
+      N=N+1
+      DATA(ID+L)=WRK(N)
+   60 CONTINUE
+      IF(NGRO.EQ.LINFO) GO TO 70
+      NREC=NREC+1
+      N=0
+      LMIN=NGRO+1
+      GO TO 50
+*
+   70 INDEX=LNEWAD(1)
+      ID=ID+LNEWAD(2)
+      IF(ID.EQ.LGSEG) GO TO 80
+      GO TO 10
+   80 DEALLOCATE(WRK)
+      IF(LNEWAD(1).NE.-1) CALL XABORT('AEXDIR: DIRECT ACCESS READ FAIL'
+     1 //'URE(3).')
+      RETURN
+   90 CALL XABORT('AEXDIR: DIRECT ACCESS READ FAILURE(2).')
+      END