how to detect file already open before executing OPEN

larryscheier · ‎03-03-2009

I have a very simple OPEN statement that is only executed if the file exists:
INQUIRE(FILE=DsnProfExportName, EXIST=FILE_EXIST)
IF (FILE_EXIST) THEN
OPEN(90,FILE=DsnProfExportName, STATUS='OLD', ERR= 100)
END IF
....
!Error trap
100 ErrorFound = .TRUE.

I thought the "ERR=100" would be able to trap an error such as when the file is already open in Excel but instead of going to statement 100, the runtime crashes on the line with the OPEN statement and displays: "forrtl: severe (46): inconsistent OPEN/CLOSE parameters, unit 90, file unknown"

If the "ERR=xxx" can't catch if the file is already open in another process is there a way to at least detect an already open file (especially one that is write protected)?

Thanks!
Lawrence

DavidWhite · ‎03-03-2009

Quoting - larryscheier

I have a very simple OPEN statement that is only executed if the file exists:
INQUIRE(FILE=DsnProfExportName, EXIST=FILE_EXIST)
IF (FILE_EXIST) THEN
OPEN(90,FILE=DsnProfExportName, STATUS='OLD', ERR= 100)
END IF
....
!Error trap
100 ErrorFound = .TRUE.

I thought the "ERR=100" would be able to trap an error such as when the file is already open in Excel but instead of going to statement 100, the runtime crashes on the line with the OPEN statement and displays: "forrtl: severe (46): inconsistent OPEN/CLOSE parameters, unit 90, file unknown"

If the "ERR=xxx" can't catch if the file is already open in another process is there a way to at least detect an already open file (especially one that is write protected)?

Thanks!
Lawrence

Lawrence,

the INQUIRE statement can take a number of other keywords, including WRITE - this may indicate that you cannot access the file for writing, so would indicate that it is already in use.

David

TimP · ‎03-03-2009

It might be better to use also an OPENED= specifier in the INQUIRE. It does look like the ERR= is misbehaving.

Steven_L_Intel1 · ‎03-03-2009

Is this excerpt faithfully representative of your actual application, or is it a "paraphrase"? What is the actual OPEN?

larryscheier · ‎03-04-2009

Quoting - tim18

It might be better to use also an OPENED= specifier in the INQUIRE. It does look like the ERR= is misbehaving.

Using either WRITE or OPENED in the INQUIRE function did not detect that the file was already open in Excel.

To answer Steve, a larger snippet was:
INQUIRE(FILE=DsnProfExportName, EXIST=FILE_EXIST)
IF (FILE_EXIST) THEN
OPEN(90,FILE=DsnProfExportName, STATUS='OLD', ERR=100)
CLOSE(90,STATUS='DELETE')
END IF
OPEN(90, FILE = DsnProfExportName, ACCESS = 'SEQUENTIAL', &
FORM = 'FORMATTED', STATUS = 'NEW')

This is code from the 70's. The only point of the first OPEN was to allow the subsequent CLOSE statement to delete the file if it existed or to error trap a problem.

Taking a hint from Steve's response, the "ERR=100" was able to detect that the file was already open in Excel by adding ACTION=WRITE to it:
OPEN(90,FILE=DsnProfExportName, ACTION = 'WRITE', STATUS='OLD', ERR=100)

Thanks, Steve!

Lawrence

Steven_L_Intel1 · ‎03-04-2009

Ah, yes. If you don't specify ACTION, then the OPEN thinks you might be interested in reading only and waits for you to try to write to give an error. Having been through this before I'll note that some tools, such as Notepad or Visual Studio, do not leave the file open after reading the contents so there is no way I know of to detect that it is "open".

jimdempseyatthecove · ‎03-04-2009

Lawrence,

The code is almost right

[cpp]INQUIRE(FILE=DsnProfExportName, EXIST=FILE_EXIST)
! Race condition here
IF (FILE_EXIST) THEN
  ! ** existing file on INQUIRE might not exist at time of OPEN
  OPEN(90,FILE=DsnProfExportName, ACTION = 'WRITE', STATUS='OLD', ERR=100)
  CLOSE(90,STATUS='DELETE')
END IF
! ** If file did not exist at INQUIRE, file may exist now
! ** If file deleted above, file may exist now
OPEN(90, FILE = DsnProfExportName, ACCESS = 'SEQUENTIAL', &
FORM = 'FORMATTED', STATUS = 'NEW')




In your code above (revised with my comments) there is a small window of time
(aka race condition) where your technique will fail


.




[/cpp]

jimdempseyatthecove · ‎03-04-2009

(Damb edit window wouldn't let me type past pasted text...)

What you might want to consider to close the race condition window is a loop that performs

a) open with replace
b) open with new

The loop repeats until you get a file busy (in use) or success
i.e. open with replace could error with "file not found" an acceptible error
then open with new could error with "existing file" (other program opened file)
looping back open with replace could potentially succeed or you get a file busy (in use)

On the file is busy you might want to pop-up "File in use! Retry, Abort?"

Or something like that.

What is really annoying is to encounter a race condition like that after 10 hours of computation time.
An abort means you have to re-run the computation.

Jim Dempsey

Paul_Curtis · ‎03-04-2009

The Windows API provides a wealth of file-handling functions which are much more versatile than the ones packaged with Fortran, albeit at a loss of portability. You can use CreateFile with OPEN_ALWAYS to ensure that the file is opened as new whether it exists or not, and the return indicates whether a sharing violation was encountered, which you could try to wait out, or deal with in some other way:

[cpp]	10  ihandl = CreateFile (fullpath,					&
					 access,					&
					 IOR(FILE_SHARE_READ,FILE_SHARE_WRITE),	&
					 NULL_SECURITY_ATTRIBUTES,	& 
					 OPEN_ALWAYS,				&
					 FILE_ATTRIBUTE_NORMAL,		&
					 NULL						)

		IF (ihandl == INVALID_HANDLE_VALUE) THEN
		    IF (GetLastError() == ERROR_SHARING_VIOLATION) THEN
		        ntry = ntry + 1
		        IF (ntry > max_try) RETURN
		        CALL delay_ms (5)
		        GO TO 10
		    END IF
		END IF[/cpp]

WHeat_ · ‎04-14-2014

Hi Steve,

I have the same problem when I am working on a machine that win 8.1 is installed. But when I'm working on a machine that is installed win 7, it works and I do not have this message !

MP=10

INQUIRE(file='output.out',exist=FILE_EXIST)

      IF(FILE_EXIST)THEN
        OPEN(10,file='output.out',STATUS='OLD')
        CLOSE(unit=MP,STATUS='DELETE')
      ENDIF
      open(10,FILE='output.out',STATUS='NEW')

Steven_L_Intel1 · ‎04-14-2014

What is the message?

Try adding:

CALL SLEEPQQ(500) after the CLOSE. Add USE IFPORT after the SUBROUTINE, FUNCTION or PROGRAM statement to make this available.

jimdempseyatthecove · ‎04-14-2014

What you might want to do is, after the OPEN for the delete, prior to CLOSE with delete, is to rename the file. Then close it.

Reason, Windows may defer the actual deletion, and your OPEN to create may occur before the file is actually deleted.

Also, when you open for deletion, the file may already be opened. If it is, the rename may fail and/or the CLOSE with delete may fail. You will have to add code to handle these exception conditions.

Jim Dempsey

WHeat_ · ‎04-14-2014

When I add :

CALL SLEEPQQ(500) after the CLOSE,

severe (28): CLOSE error, unit 10, file "Unknown"

Steven_L_Intel1 · ‎04-14-2014

Would you please post a small but complete program that demonstrates the problem? Use the "Code" button (looks like {...} in the toolbar here) for best formatting.

WHeat_ · ‎04-14-2014

Hi Steve,

at first, the code is written in F77, I tried to convert it to F90 because I could not with compile it with MVS2012, but the problem now (after conversion to f90) that there are some errors!

there I posted a part of the program with some subroutines.
Thank you for your help.

 PROGRAM MEF
!
!===========================================================================
!
      IMPLICIT REAL*8(A-H,O-Z)                                          

      logical ::ilela
      REAL:: BLOC,BLOCS                                                 
      COMMON/ALLOC/NVA,IVA,IVAMAX,NREEL,NTBL                            
      COMMON/ES/M,MR,MP,MLUN(10)                                        
      COMMON VA(2000000)                                                
      DIMENSION BLOCS(17)                                               
      DATA BLOCS/4HIMAG,4HCOMT,4HCOOR,4HCOND,4HPREL,  &    
     &           4HELEM,4HNLID,4HNLIN,4HSTAT,4HSTAD,   &
     &           4HPATE,4HCYSA,4HSTAB,4HSPHO,4HBROC,4H....,4HSTOP/     
      DATA NB/17/                                                        
!      character*40 nomgen,nomfic
!      logical ilela
!......DIMENSION DU COMMON BLANC EN MOTS REELS (TABLE VA)            
!      NVA=20000
      NVA = 2000000
!-----------------------------------------------------------------------
!--------initialisation-------------------------------------------------
!
!
!
!------- READING OF FILES INPUT-OUTPUT----------------------------------
!
      MR=5

      OPEN(5,file='input.inp',status='old')

      MP=10

      INQUIRE(file='output.out',exist=ilela)
      IF(ilela)THEN
        OPEN(10,file='output.out',status='old')
        CLOSE(unit=mp,status='delete')
      ENDIF
      open(10,file='output.out',status='new')
      open(7,file='input.cor',status='old')

      open(8,file='input.ele',status='old')
      
      INQUIRE(file='output.sol',exist=ilela)
      IF(ilela)THEN
        OPEN(9,file='output.sol',status='old')
        CLOSE(unit=9,status='delete')
      ENDIF

      OPEN(9,file='output.sol',status='new')

      INQUIRE(file='output.sta',exist=ilela)
      IF(ilela)THEN
       OPEN(23,file='output.sta',status='old')
       CLOSE(unit=23,status='delete')
      ENDIF

      OPEN(23,file='output.sta',status='new') 

      INQUIRE(file='output.dyn',exist=ilela) 
      IF(ilela)THEN 
       OPEN(21,file='output.dyn',status='old') 
       CLOSE(unit=21,status='delete') 
      ENDIF
 
      OPEN(21,file='output.dyn',status='new') 
      INQUIRE(file='output.ini',exist=ilela) 
        
        IF(ilela)THEN 
   
      open(22,file='output.ini',status='old') 
      close(unit=22,status='delete') 
        ENDIF
 
      open(22,file='output.ini',status='new') 
 
      INQUIRE(file='output.map',exist=ilela) 
      IF(ilela)THEN  
       OPEN(27,file='output.map',status='old') 
       CLOSE(unit=27,status='delete') 
      ENDIF 
      OPEN(27,file='output.map',status='new') 
!!----------------------------------------------------------------------- 
!C......DIMENSION DU COMMON BLANC EN MOTS REELS (TABLE VA)             
!c      NVA=2000000 
!!-------  EN-TETE; par defaut *=6---------------------------------------                                                       

      WRITE(*,2000)                                                     
2000  FORMAT(//10X,'************************************************'/ &
     &         10X,'*                                              *'/ &
     &         10X,'*               PALFLU                         *'/ &
     &         10X,'*                                              *'/ &
     &         10X,'*    Modelisation of bearing by M.E.F          *'/& 
     &         10X,'*    Laboratoire MSHP                          *'/& 
     &         10X,'*                                              *'/ &  
     &         10X,'************************************************'//) 
!!-------  LECTURE DE L'EN-TETE D'UN BLOC                                 
10    READ(MR,1000) BLOC,M,MLUN                                          
1000  FORMAT(A4,I6,10I5)                                                 
!!-------  RECHERCHE DU BLOC A EXECUTER                                   
      DO 20 I=1,NB                                                       
      IF(BLOC.EQ.BLOCS(I)) GO TO 30                                      
20    CONTINUE                                                         
      WRITE(MP,2010)                                                     
2010  FORMAT('  ** ERREUR    CARTE D''APPEL DE BLOC MANQUANTE')              
      GO TO 10                                                           
30    GO TO (110,120,130,150,170, &                               
     &       180,220,230,240,250,260,300,310,350,360,370,999),I                       
!!-------  BLOC D'IMPRESSION DE L'ENSEMBLE DES DONNEES      'IMAG'        
110   CALL BLIMAG                                                        
      GO TO 10                                                           
!-------  BLOC DE LECTURE-IMPRESSION DE COMMENTAIRES       'COMT'        
120   CALL BLCOMT                                                        
      GO TO 10                                                           
!-------  BLOC DE LECTURE DES NOEUDS                       'COOR'        
130   CALL BLCOOR                                                        
      GO TO 10                                                           
!cc!-------  BLOC DE LECTURE DES DEGRES DE LIBERTE PAR NOEUD  'DLPN'        
!cc140   CALL BLDLPN                                                        
!cc      GO TO 10                                                           
!!-------  BLOC DE LECTURE DES CONDITIONS AUX LIMITES       'COND'        
150   CALL BLCOND                                                        
      GO TO 10                                                           
!c!-------  BLOC DE LECTURE DES PROPRIETES NODALES           'PRND'        
!c160   CALL BLPRND                                                        
!c      GO TO 10                                                           
!!-------  BLOC DE LECTURE DES PROPRIETES ELEMENTAIRES      'PREL'        
170   CALL BLPREL                                                        
      GO TO 10                                                           
!!-------  BLOC DE LECTURE DES ELEMENTS                     'ELEM'        
180   CALL BLELEM                                                        
      GO TO 10                                                           
!!-------  BLOC DE LECTURE DES SOLLICITATIONS CONCENTREES   'SOLC'        
!cc190   CALL BLSOLC                                                        
!cc      GO TO 10                                                           
!!-------  BLOC DE LECTURE DES SOLLICITATIONS REPARTIES     'SOLR'        
!cc200   CALL BLSOLR                                                        
!cc      GO TO 10                                                           
!!-------  BLOC DE RESOLUTION LINEAIRE EN MEMOIRE           'LINE'        
!c210   CALL BLLINE  
!c      GO TO 10                                                           
!!-------  BLOC DE RESOLUTION stat ADIMENSIONNELLE          'NLID'        
220   CALL BLNLID  
      GO TO 10                                                           
!!-------  BLOC DE RESOLUTION NON LINEAIRE stat             'NLIN'        
230   CALL BLNLIN  
      GO TO 10                                                           
!!-------  BLOC DE RESOLUTION NON STATIONAIRE T3  Dimen     'STAT'        
240   CALL BLSTAT  
      GO TO 10                                                           
!!-------  BLOC DE RESOLUTION NON STATIONAIRE T3  adimen     'STAD'        
250   CALL BLSTAD  
      GO TO 10                                         
!!-------  BLOC DE RESOLUTION NON STATIONAIRE T3=240 Dimen   'PATE'        
260   CALL BLPATE  
      GO TO 10                                                           
!!-------  BLOC DE CALCUL DE DEBIT ET PRESSION AUX POCHES  
!!-------  UTILISANT L'ITERATION                            'STAT'        
!cc260   CALL BLSTAT 
!cc      GO TO 10                                                           
!!-------  BLOC D'ANALYSE DES PROPRIETES DYNAMIQUES (rou)   'DYNA' 
!cc270   CALL BLDYNA 
!cc      GO TO 10 
!!---- BLOC DE PALIER HYDROSTATIQUE DE FACON IMPLICITE (rou)'STA1' 
!cc280   CALL BLSTA1 
!cc      GO TO 10 
!!----- BLOC D'ANALYSE DE PALIER POREUX                     'PORE' 
!cc290   CALL BLPORE 
!cc      GO TO 10  
!!----- BLOC D'ANALYSE D'UN PALIER CYLINDRIQUE AEROSTAT     'BROC' 
300    CALL BLCYSA 
       GO TO 10 
!!----- BLOC DE PALIER AEROSTATIQUE EN REGIME VIBRATOIRE    'STAB' 
!!------ ANALYSE DE STABILITE 
310   CALL BLSTAB 
      GO TO 10 
!!----- BLOC DE PALIER HYDROSTATIQUE EN REGIME TURBULENT    'TURD' 
!!----- ANALYSE DYNAMIQUE non-LINEAIRE adim  
!cc320   CALL BLTURD 
!cc      GO TO 10 
!!----- BLOC DE PALIER HYDROSTATIQUE EN REGIME TURBULENT    'TURM' 
!!----- ANALYSE DYNAMIQUE NON-LINEAIRE 
!cc330   CALL BLTURM 
!cc      GO TO 10 
!cc340   CALL BLVIB1 
!cc      GO TO 10 
!!----- BLOC DE PALIER SPHERIQUE AERO... A MULTIPLES ORIFICES    'SPHO' 
350   CALL BLSPHO 
      GO TO 10 
!!-------  BLOC NON DEFINIS          
!!----- BLOC D'ANALYSE D'UN PALIER CYLINDRIQUE AEROSTAT     'BROC' 
360    CALL BLBROC 
       GO TO 10 
!C......... 
370   CONTINUE 
      GO TO 10 
!!-------  FIN DU PROBLEME                                  'STOP'        
999   WRITE(MP,2020) IVAMAX,NVA                                          
2020  FORMAT(//' FIN DU PROBLEME, ',I10,' MOTS REELS UTILISES SUR ',I10) 
      STOP                                                               
      END
        SUBROUTINE BLIMAG
!===========================================================================
!     APPEL ET EXECUTION DU BLOC 'IMAG'
!     IMPRESSION DE L'ENSEMBLE DES CARTES DE DONNEES
!===========================================================================
    
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/ES/M,MR,MP,M1
      COMMON/TRVL/CART(20)
      DATA ICARTM/40/
!------------------------------------------------------
       print*,'je suis dans BLIMAG au debut '
      IF(M1.EQ.0) M1=MR
      WRITE(MP,2000)
2000  FORMAT(///,1X,'IMAGE DES DONNEES SUR CARTES'/1X,28('='),/)
      WRITE(MP,2005)
2005  FORMAT(/                                                            &
     &  50X,'N U M E R O   D E   C O L O N N E',/,13X,'NUMERO',6X,        &
     &  10X,'1',9X,'2',9X,'3',9X,'4',9X,'5',9X,'6',9X,'7',9X,'8',/,       &
     &  12X,'DE CARTE',6X,8('1234567890'),/,12X,8('-'),6X,80('-'))        
      ICART=0
      ICART1=0
10    READ(M1,1000,END=30) CART
1000  FORMAT(20A4)
      ICART=ICART+1 
      ICART1=ICART1+1
      IF(ICART1.LE.ICARTM) GO TO 20		
      WRITE(MP,2010)
2010  FORMAT(12X,8(1H-),6X,80(1H-),/,13X,'NUMERO',7X,8('1234567890'),/,    &
     &  12X,'DE CARTE',6X,9X,'1',9X,'2',9X,'3',9X,'4',9X,'5',9X,'6',       &
     &  9X,'7',9X,'8',/,50X,'N U M E R O   D E   C O L O N N E')
      WRITE(MP,2015)
2015  FORMAT(1H1,//)
      WRITE(MP,2005)
      ICART1=0
20    WRITE(MP,2020) ICART,CART
2020  FORMAT(10X,I10,6X,20A4)
      GO TO 10
30    WRITE(MP,2010)
      WRITE(MP,2030)
2030  FORMAT(///51X,'F I N   D E S   D O N N E E S'///)
      REWIND M1
      READ(M1,1000) CART
      print*,' fin de BLIMAG'
      RETURN
    END
    
    SUBROUTINE BLCOMT
!===========================================================================
!     APPEL ET EXECUTION DU BLOC 'COMT'
!===========================================================================
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*4 BLANC,CART
      COMMON/ES/M,MR,MP
      COMMON/TRVL/CART(20)
      DATA BLANC/4H    /
!----------------------------------------------------------------------
      WRITE(MP,2000)
2000  FORMAT(//' COMMENTAIRES'/' ',13('=')/)
!---------- LECTURE D'UNE CARTE DE COMMENTAIRE
10    READ(MR,1000) CART
1000  FORMAT(20A4)
!---------- RECHERCHE D'UNE CARTE DE ENTIEREMENT BLANCHE
      DO 20 I=1,20
      IF(CART(I).NE.BLANC) GO TO 30
20    CONTINUE
      RETURN
30    WRITE(MP,2010) CART
2010  FORMAT(1X,20A4)
      GO TO 10
      END 
SUBROUTINE BLCOOR
!========================================================================
!     APPEL DU BLOC 'COOR'
!     LECTURE DES COORDONNEES DES NOEUDS
!========================================================================
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*4 TBL
      COMMON/COOR/NDIM,NNT,NDLN,NDLT,FAC(3)
      COMMON/ALLOC/NVA
      COMMON/ES/M,MR,MP,M1
      COMMON/LOC/LCORG,LDLNC
      COMMON/TRVL/FAC1(3),IN(3)
!c    
      COMMON VA(1)
      DIMENSION TBL(2)
      DATA ZERO/0.D0/,TBL/4HCORG,4HDLNC/
!---------------------------------------------------------------------------
!--------- EN-TETE DE BLOC 
  print*,'DEBUT DE BLCOOR *-*-*-*-'
  print*,FAC1
      IF(M1.EQ.0) M1=MR
      READ(M1,1000)IN,FAC1 
1000  FORMAT(3I5,3F10.0)
      print*,MP
!------------- OPTIONS PAR DEFAUT
      IF(IN(1).GT.0) NNT=IN(1) 
      IF(IN(2).GT.0) NDLN=IN(2) 
      IF(IN(3).GT.0) NDIM=IN(3) 
      DO 10 I=1,3
      IF(FAC1(I).NE.ZERO) FAC(I)=FAC1(I)
10    CONTINUE
      
!--------- IMPRESSION DES PARAMETRES DU BLOC 
      WRITE(MP,2000)M,NNT,NDLN,NDIM,FAC,NVA
2000  FORMAT(///' LECTURE DES NOEUDS (M=',I2,')'/' ',18('=')/        &
     &  15X,'NOMBRE MAX. DE NOEUDS               (NNT)=',I5/        &
     &  15X,'NOMBRE MAX. DE D.L. PAR NOEUD      (NDLN)=',I5/        &
     &  15X,'NOMBRE DE DIMENSIONS DU PROBLEME   (NDIM)=',I5/        &
     &  15X,'FACTEUR D ECHELLE DE SENS X         (FAC)=',E12.5/     &
     &  15X,'FACTEUR D ECHELLE DE SENS Y         (FAC)=',E12.5/     &
     &  15X,'FACTEUR D ECHELLE DE SENS Z         (FAC)=',E12.5/     &
     &  15X,'ESPACE DE TRAVAIL EN MOTS REELS     (NVA)=',I10)
!--------- ALLOCATION D'ESPACE 
      IF(LCORG.EQ.1) CALL ESPACE(NNT*NDIM,1,TBL(1),LCORG) 
      IF(LDLNC.EQ.1) CALL ESPACE(NNT+1,0,TBL(2),LDLNC)
      write(MP,*) VA(LCORG),VA(LDLNC),LDLN,LCORG 
!---------- EXECUTION DU BLOC
     ! CALL EXCOOR(VA(LCORG),VA(LDLNC))
       RETURN
      END
      
 ! la subroutinre BLCOOR  fait appel à deux SUB : ESPACE  &  EXCOOR
 !  ce dernier fait appel à ERREUR
  SUBROUTINE ESPACE(ILONG,IREEL,TBL,IDEB)
!=======================================================================
!     ALLOCATION D'UNE TABLE REELLE OU ENTIERE DANS LA TABLE VA
!        ENTREES
!           ILONG            LONGUEUR DE LA TABLE A CREER
!                            (EN MOTS REELS OU ENTIERS)
!           IREEL            TYPE DE LA TABLE :
!                                 .EQ.0     ENTIERE
!                                 .EQ.1     REELLE
!           TBL              NOM DE LA TABLE (A4)
!        SORTIES   
!           IDEB             LA TABLE CREEE DEBUTE EN VA(IDEB)
!========================================================================
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*4 TBL
      COMMON/ES/M,MR,MP
      COMMON/ALLOC/NVA,IVA,IVAMAX,NREEL
      COMMON VA(1)
      DIMENSION KA(1)
      EQUIVALENCE (VA(1),KA(1))
      DATA ZERO/0.D0/
!--------------------------------------------------------------------       
!-------- CALCULER LA LONGUEUR DE LA TABLE EN MOTS REELS
      ILGR=ILONG
      IF(IREEL.EQ.0) ILGR=(ILONG+NREEL-1)/NREEL
      IVA1=IVA+ILGR
!------------- VERIFIER SI L'ESPACE EST DISPONIBLE
      IF(IVA1.LE.NVA) GO TO 20
!--------- EXTENSION AUTOMATIQUE DU COMMON BLANC SI LA COMMANDE
!          SYSTEME CORRESPONDANTE EXISTE SUR LE CALCULATEUR UTILISE
!     CALL EXTEND(IVA1,IERR)
!     IF(IERR.EQ.1) GO TO 10
!     NVA=IVA1
!     GO TO 20
!-------- ERREUR D'ALLOCATION (MANQUE D'ESPACE)
10    WRITE(MP,2000) TBL,IVA1,NVA
2000  FORMAT(' **** ERREUR D ALLOCATION,TABLE ',A4/' ESPACE REQUIS:',     &  
     &  I7,' MOTS REELS, ESPACE DISPONIBLE:',I7,' MOTS REELS')
      STOP
!-------- ALLOCATION DE LA TABLE
20    IDEB=IVA+1
      IVA=IVA1
      IF(IVA.GT.IVAMAX) IVAMAX=IVA
      IF(M.GT.0) WRITE(MP,2010) TBL,IDEB,IVA1
2010  FORMAT(5X,'TABLE ',A4,' PLACE DE VA(',I7,') A LA(',I7,')'/)
!--------- INITIALIASION A ZERO DE LA TABLE CREEE
      I1=IDEB
      IF(IREEL.EQ.0) I1=(I1-1)*NREEL+1
      I2=I1+ILONG-1
      IF(IREEL.EQ.0) GO TO 40
      DO 30 I=I1,I2
30    VA(I)=ZERO
      RETURN
40    DO 50 I=I1,I2
50    KA(I)=0
      RETURN
      END

      SUBROUTINE EXCOOR(VCORG,KDLNC)
!========================================================================
!     EXECUTION DU BLOC 'COOR'
!     LECTURE DES COORDONNEES DES NOEUDS
!========================================================================
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/COOR/NDIM,NNT,NDLN,NDLT,FAC(3)
      COMMON/ES/M,MR,MP,M1
      COMMON VA(1)
      COMMON/TRVL/X1(3),X2(3)
      DIMENSION VCORG(1),KDLNC(1)
      DATA SPECL/1.23456789D31/
!c      DATA SPECL/2.714797858330726E-314/
!--------------------------------------------------------------------------
!---------- INITIALISATION DES COORDONNEES
      I1=(NNT-1)*NDIM+1
      DO 10 I=1,I1,NDIM
10    VCORG(I)=SPECL
!--------- LECTURE DES CARTES DE NOEUDS
      IF(M.GT.0) WRITE(MP,2000)
2000  FORMAT(//' CARTES DE NOEUDS'/)
20    READ(M1,1000) IN1,X1,IN2,X2,INCR,IDLN
1000  FORMAT(2(I5,3F10.0),2I5)
      IF(M.GT.0) WRITE(MP,2010) IN1,X1,IN2,X2,INCR,IDLN
2010  FORMAT(//' >>>>>',2(I5,3E12.5),2I5)
      IF(IN1.LE.0) GO TO 60
!--------- DECODAGE DE LA CARTE
      IF(IN1.GT.NNT) CALL ERREUR(11,IN1,NNT,0)
      IF(IN2.GT.NNT) CALL ERREUR(12,IN2,NNT,0)
      IF(IN2.LE.0) IN2=IN1
      IF(IDLN.GT.NDLN) CALL ERREUR(13,IDLN,NDLN,0)
      IF(IDLN.LE.0) IDLN=NDLN
      IF(INCR.EQ.0) INCR=1
      I1=(IN2-IN1)/INCR
      I2=IN1+I1*INCR
      IF(I1.EQ.0) I1=1
      IF(IN2.NE.I2) CALL ERREUR(14,IN2,IN2,0)
!----------- GENERATION DES NOEUDS PAR INTERPOLATION
      DO 30 I=1,NDIM
      X1(I)=X1(I)*FAC(I)
      X2(I)=X2(I)*FAC(I)
30    X2(I)=(X2(I)-X1(I))/I1
      I1=0
      I2=(IN1-1)*NDIM+1
      I3=(INCR-1)*NDIM
      DO 50 IN=IN1,IN2,INCR
      KDLNC(IN+1)=IDLN
!c      IF(DABS(VCORG(I2)-SPECL).GE.1D-5) CALL ERREUR(15,IN,IN,0)
!c      write(MP,*) IN,KDLNC(IN+1),IDLN,VCORG(I2) 
      IF(VCORG(I2).NE.SPECL) CALL ERREUR(15,IN,IN,0)
      DO 40 I=1,NDIM
      VCORG(I2)=X1(I)+X2(I)*I1
40    I2=I2+1
      I1=I1+1
50    I2=I2+I3
      GO TO 20
!-------- VERIFICATION DES NOEUDS MANQUANTS
60    I1=NNT*NDIM+1
      I2=0
      I3=NNT+1
      DO 90 I=1,NNT
      I1=I1-NDIM
      I3=I3-1
      IF(VCORG(I1)-SPECL) 70,80,70
70    IF(I2.EQ.0) I2=I3
      GO TO 90
80    IF(I2.EQ.0) CALL ERREUR(16,I3,I3,0)
      IF(I2.NE.0) CALL ERREUR(17,I3,I3,1)
90    CONTINUE
      IF(I2.NE.NNT) CALL ERREUR(18,NNT,I2,0)
!-------- NOMBRE TOTAL DE D.L.
      NDLT=0
      I1=NNT+1
      DO 100 I=2,I1
100   NDLT=NDLT+KDLNC(I)
!--------- IMPRESSIONS
      IF(M.GT.2) GO TO 120
      WRITE(MP,2020)
2020  FORMAT(/5X,'NOEUD',5X,'D.L.',9X,'X',13X,'Y',13X,'Z'/)
      I1=1
      I2=NDIM
      DO 110 IN=1,NNT
      WRITE(MP,2030) IN,KDLNC(IN+1),(VCORG(I),I=I1,I2)
2030  FORMAT(5X,I5,2X,I5,5X,3(E12.5,2X))
      I1=I1+NDIM
110   I2=I2+NDIM
120   RETURN
    END
    SUBROUTINE ERREUR(IERR,I1,I2,INIV)
!==============================================================================
!     IMPRESSION DES ERREUES DANS LES BLOCS DES DONNEES
!==============================================================================
      COMMON/ES/M,MR,MP
!-------------------------------------------------------------------------
!--------- BLOC 'COOR'
      IF(IERR.GT.19) GO TO 200
      IE=IERR-10
      GO TO (110,120,130,140,150,160,160,180),IE
110   WRITE(MP,2110)I1,I2
2110  FORMAT(' ***ERREUR, LE NUMERO DU PREMIER NOEUD(',I4,') EST SUPERI     &
     &EUR A NNT=',I4)
      GO TO 900
120   WRITE(MP,2120)I1,I2
2120  FORMAT(' ***ERREUR, LE NUMERO DU SECOND NOEUD(',I4,') EST SUPERI     &
     &EUR A NNT=',I4)
      GO TO 900
130   WRITE(MP,2130)I1,I2
2130  FORMAT(' ***ERREUR, LE NOMBRE DE D.L. DU NOEUD(',I4,') EST SUPERI    &
     &EUR A NDLN=',I4)
      GO TO 900
140   WRITE(MP,2140)
2140  FORMAT(' ***ERREUR, LES NUMEROS DU PREMIER ET DU SECOND NOEUDS      &
     &SONT INCOMPATIBLES AVEC L INCREMENT DE GENERATION')
      GO TO 900
150   WRITE(MP,2150)I1
2150  FORMAT(' ***ERREUR, LE NOEUD ',I4,' EST DEFINI PLUSIEURS FOIS')
      GO TO 900
160   WRITE(MP,2160)I1
2160  FORMAT(' ***ERREUR, LE NOEUD ',I4,' N EST PAS DEFINI')
      GO TO 900
180   WRITE(MP,2180)I2,I1
2180  FORMAT(' ***ERREUR, LE NOMBRE DE NOEUDS CREES(',I4,') EST INFERI   &
     &EUR A NNT=',I4)
      GO TO 900
!------------ BLOC 'DLPN'
200   IF(IERR.GT.29) GO TO 300
      IE=IERR-20
      GO TO (210,220),IE
210   WRITE(MP,2210)I1,I2
2210  FORMAT(' ***ERREUR, LE NOMBRE DE D.L. (',I2,') EST SUPERIEUR A     &
     &NDLN=',I2)
      GO TO 900
220   WRITE(MP,2220)I1,I2
2220  FORMAT(' ***ERREUR, LE NUMERO D UN NOEUD(',I4,') EST SUPERIEUR     &
     &A NNT=',I4)
      GO TO 900
!--------- BLOC 'COND'
300   IF(IERR.GT.39) GO TO 400
      IE=IERR-30
      GO TO (900,320,900),IE
320   GO TO 220
!-------- BLOC 'PREL'
400   IF(IERR.GT.49) GO TO 500
      IE=IERR-40
      GO TO (410,900),IE
410   WRITE(MP,2410)I1,I2
2410  FORMAT(' ***ERREUR, LE NUMERO DE GROUPE(',I3,') EST SUPERIEUR     &
     &A NGPE=',I3)
      GO TO 900
!--------- BLOC 'ELEM'
500   IF(IERR.GT.59) GO TO 900
      IE=IERR-50
      GO TO (510,900,530,540,550,560,570),IE
510   WRITE(MP,2510)I1,I2
2510  FORMAT(' ***ERREUR, LE NOMBRE DE NOEUDS(',I3,') EST SUPERIEUR      &
     &A NNEL=',I3)
      GO TO 900
530   WRITE(MP,2530)I1,I2
2530  FORMAT(' ***ERREUR, LE NUMERO DE PROPRIETE (',I3,')  SUPERIEUR    &
     &A NGPE=',I3)
      GO TO 900
540   WRITE(MP,2540)I1,I2
2540  FORMAT(' ***ERREUR, LE NUMERO DE GROUPE (',I3,') SUPERIEUR A      &
     &NGRE=',I3)
      GO TO 900
550   WRITE(MP,2550)I1,I2
2550  FORMAT(' ***ERREUR, LE NUMERO D ELEMENT (',I4,') SUPERIEUR A      &
     & NELT=',I4)
      GO TO 900
560   GO TO 220
570   WRITE(MP,2570)I1,I2
2570  FORMAT(' ***ERREUR, NOMBRE D ELEMENTS (',I4,')  SUPERIEUR A      &
     &NELT=',I4)
!--------- FIN
900   I1=I2
      IF(INIV.GE.2) STOP
      RETURN
    END         

     SUBROUTINE ASEULR(IKT,VCORG,KDLNC,VDIMP,KNEQ,KLD,KLOCE,VCORE,&
     &  VPRNE,VPREE,KNE,VKE,VME,VFE,VDLE,VKGS,VKGD,VKGI,VFG,VRES, &
     &  VDLG,VDLE0,VDLG0,VFG0)
!=======================================================================
!     ASSEMBLAGE DES RESIDUS ET DE LA MATRICE GLOBALE (SI IKT.EQ.1)
!     DANS LA MEME BOUCLE SUR LES ELEMENTS (POUR LA METHODE DE EULER)
!=======================================================================
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/ELEM/NELT,NNEL,NTPE,NGRE,ME,NIDENT                         
      COMMON/ASSE/NSYM
      COMMON/RESO/NEQ
      COMMON/RGDT/IEL,ITPE,ITPE1,IGRE,IDLE,ICE,IPRNE,IPREE,INEL,IDEG,IPG  &
     &  ,ICOD                                                           
      COMMON/NLIN/EPSDL,XNORM,OMEGA,XPAS,DPAS,DPAS0,NPAS,IPAS,NITER,  &
     &  ITER,IMETH
      COMMON/AERO/VDLEI(3),HTE0,HTE1
      COMMON/ES/M,MR,MP,M1,M2
      DIMENSION VCORG(1),KDLNC(1),VDIMP(1),KNEQ(1),KLD(1),KLOCE(1),  &
     &  VCORE(1),VPRNE(1),VPREE(1),KNE(1),VKE(1),VME(1),VFE(1),VDLE(1),    &
     &  VKGS(1),VKGD(1),VKGI(1),VFG(1),VRES(1),VDLG(1),  &
     &  VDLE0(1),VDLG0(1),VFG0(1)
      DATA UN/1.D0/
!--------------------------------------------------------------------
!------POSITIONNER AU DEBUT LE FICHIER DES ELEMENTS (M2)                
      REWIND M2                                                         
!------ BOUCLE SUS LES ELEMENTS
      DO 90 IE=1,NELT                                                  
!------ LIRE UN ELEMENT SUR LE FICHIER (M2)
      CALL RDELEM(M2,KLOCE,VCORE,VPRNE,VPREE,KNE)              
!-------  CALCUL DES FONCTIONS D'INTERPOLATION SI NECESSAIRE   
      IF(ITPE.EQ.ITPE1) GO TO 10                              
      ICOD=2                                                   
      CALL ELEMLB(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) 
!-------- EXTRAIRE LES D.L. DE L'ELEMENT DE FG
10    CALL DLELM(KLOCE,VdlG,VDIMP,VDLE)
!------- CALCULER LES RESIDUS ELEMENTAIRES 
      ICOD=6
      CALL DLELM(KLOCE,VDLG0,VDIMP,VDLEI)                                                            
      CALL ELEMLB(VCORE,VPRNE,VPREE,VDLE,VKE,VFE)
!--------- CALCUL DE LA MATRICE K SI NECESSAIRE
      IF(IKT.EQ.0) GO TO 80
      ICOD=4 
      CALL ELEMLB(VCORE,VPRNE,VPREE,VDLE,VKE,VFE)
!-------- ASSEMBLAGE DES RESIDUS ET DE LA MATRICE GLOBALE
80    CALL ASSEL(IKT,1,IDLE,NSYM,KLOCE,KLD,VKE,VFE,VKGS,VKGD,VKGI,VRES)
90    ITPE1=ITPE
      RETURN
      END

WHeat_ · ‎04-14-2014

at first, the code is written in F77, I tried to convert F90 because I could not compile it with MVS 2012. but the problem now ( after conversion ti f90) that there are errors!

there I posted a part of the program with some subroutines.
Thank you for your help

andrew_4619 · ‎04-15-2014

That compiles OK, I presume you mean runtime errors?

As I tip is is good to have IOSTAT=ivar on all OPEN / CLOSE statements. If there is an error the ivar vraiable will get a non zero value set with the error code, and then you have IF( ivar /= 0) dosomething. This is a better behaviour than the default which is to crash!

WHeat_ · ‎04-15-2014

Yes, Microsoft Visual C++ Runtime Library

"Bebug Assertion Failed!"

WHeat_ · ‎04-15-2014

It's a good idea to have IOSTAT=ivar on all OPEN / CLOSE

INQUIRE(file='output.out',exist=ilela)

      IF(ilela)THEN
       PRINT*,ILELA
        OPEN(10,file='output.out',status='old', IOSTAT=ivar)
        print*,ivar ! (ivar = 0)

        CLOSE(unit=mp,status='delete', IOSTAT=ivar)
        print*,ivar ! (ivar = 46)
      ENDIF

The value of ivar is 46!

andrew_4619 · ‎04-15-2014

https://software.intel.com/sites/products/documentation/hpc/composerxe/en-us/2011Update/fortran/win/bldaps_for/common/bldaps_rterrs.htm

46

severe (46): Inconsistent OPEN/CLOSE parameters

FOR$IOS_INCOPECLO. Specifications in an OPEN or CLOSE statement were inconsistent. Some invalid combinations follow:

READONLY or ACTION='READ' with STATUS='NEW' or STATUS='SCRATCH'
READONLY with STATUS='REPLACE', ACTION='WRITE', or ACTION='READWRITE'
ACCESS='APPEND' with READONLY, ACTION='READ', STATUS='NEW', or STATUS='SCRATCH'
DISPOSE='SAVE', 'PRINT', or 'SUBMIT' with STATUS='SCRATCH'
DISPOSE='DELETE' with READONLY
CLOSE statement STATUS='DELETE' with OPEN statement READONLY
ACCESS='DIRECT' with POSITION='APPEND' or 'ASIS'

andrew_4619 · ‎04-15-2014

That suggests the file is readonly either because of the file attribute or its location, windows 7 and 8 automatically 'protect' quite a lot of folders e.g. stuff in 'program files' folders for example.

If you opened it with write or readwrite status you will probably get an error on the open statement instead!