C C PURPOSE: OPENS A FILE C C INPUTS: C C IUNIT UNIT NUMBER. THIS NUMBER IS FOUND BY THE ROUTINE AND C RETURNED C FILE FILE NAME C IRECW =0 SEQUENTIAL UNFORMATTED FILE C =1 SEQUENTIAL FORMATTED FILE C .GT.1 DIRECT ACCESS FILE. IRECW IS RECORD LENGTH IN WORDS C STAT STATUS (= 'OLD', 'NEW' OR 'UNKNOWN') C C NB. ON SOME MACHINES THE RECORD LENGTH MUST BE GIVEN IN BYTES C C LU(K) IS .TRUE. IF UNIT NUMBER K CORRESPONDS TO AN OPEN FILE C UNIT NUMBERS FROM LU1 AND UPWARDS ARE USED. ON THE FIRST CALL C LU IS INITIALIZED TO .FALSE. C OUTPUTS: C C COMMON: C COPCL CLU CBCNST C C COMMENTS: OCTOBER 6, 1999, P. JUDGE C SUBROUTINE OPEN(IUNIT,FILE,IRECW,STAT0) INCLUDE 'PREC' INCLUDE 'COPCL' INCLUDE 'CLU' INCLUDE 'CBCNST' C CHARACTER*(*) FILE,STAT0 CHARACTER*10 STAT SAVE ICALL DATA ICALL/0/,LU1/20/ C ICALL=ICALL+1 C C INITIALIZE LU IF FIRST CALL C IF(ICALL.EQ.1) THEN DO 100 I = 1,MAXLU LU(I) = .FALSE. 100 CONTINUE END IF C C FIND FIRST FREE UNIT NUMBER C DO 200 I = LU1,MAXLU IF (.NOT.LU(I)) GO TO 300 200 CONTINUE CALL STOP('OPEN: NO FREE UNIT NUMBER') 300 CONTINUE LU(I)=.TRUE. IUNIT=I C C TREATMENT OF STATUS='NEW' C IF(STAT0.EQ.'NEW') THEN STAT=NEWSTA ELSE STAT=STAT0 ENDIF C IF(IRECW.EQ.0) THEN OPEN(IUNIT,FILE=FILE,FORM='UNFORMATTED',STATUS=STAT) C (note this next line from 6jul22 update) ELSE IF(IRECW.EQ.-1) THEN OPEN(IUNIT,FILE=FILE,FORM='UNFORMATTED',STATUS=STAT, * ACCESS="STREAM") ELSE IF(IRECW.EQ.1) THEN OPEN(IUNIT,FILE=FILE,FORM='FORMATTED',STATUS=STAT) ELSE IF(IRECW.GT.1 .AND. STAT(1:3) .NE. 'OLD') THEN OPEN(IUNIT,FILE=FILE,ACCESS='DIRECT',RECL=IRC*IRECW, * FORM='UNFORMATTED',STATUS=STAT) ELSE IF(IRECW.GT.1 .AND. STAT(1:3).EQ.'OLD') THEN C C NB THE RESULT OF THE INQUIRE STATEMENT IS MACHINE DEPENDENT C ON VAX-COMPUTERS THE RECL IS RETURNED IN BYTES C INQUIRE(FILE=FILE,RECL=IRECB) IF(IRECB.NE.0) IRECW=IRECB/4/IRC OPEN(IUNIT,FILE=FILE,ACCESS='DIRECT',RECL=IRC*IRECW, * FORM='UNFORMATTED',STATUS=STAT) ELSE CALL STOP('OPEN: IRECW.LT.0') END IF C RETURN END C C*********************************************************************** C