!! Copyright (C) Stichting Deltares, 2012-2014. !! !! This program is free software: you can redistribute it and/or modify !! it under the terms of the GNU General Public License version 3, !! as published by the Free Software Foundation. !! !! This program is distributed in the hope that it will be useful, !! but WITHOUT ANY WARRANTY; without even the implied warranty of !! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the !! GNU General Public License for more details. !! !! You should have received a copy of the GNU General Public License !! along with this program. If not, see . !! !! contact: delft3d.support@deltares.nl !! Stichting Deltares !! P.O. Box 177 !! 2600 MH Delft, The Netherlands !! !! All indications and logos of, and references to registered trademarks !! of Stichting Deltares remain the property of Stichting Deltares. All !! rights reserved. SUBROUTINE RD_FILID ( DEFFDS, FFORM , VFFORM, CONTEN, + VERSIO, SERIAL, RUNDAT, SOURCE, REMARK, + LUNREP, IERROR) C C Deltares C C CREATED : june 1999 by Jan van Beek C C FUNCTION : Read File Identification group from NEFIS file C C FILES : NEFIS file assumed opened C C SUBROUTINES CALLED : C C ARGUMENTS C C NAME TYPE LENGTH FUNCT. DESCRIPTION C ---- ----- ------ ------- ----------- C DEFFDS INT 2993 I/O Definition file descriptor C DATFDS INT 999 I/O Data file descriptor C FFORM CH*40 1 O File Format C VFFORM REAL 1 O Version File Format C CONTEN CH*40 1 O File contents C VERSIO REAL 1 O Version number process library C SERIAL INT 1 O File serial number C RUNDAT CH*20 1 O Creation date C SOURCE CH*40 1 O Source data C REMARK CH*40 4 O Remarks C LUNREP INT 1 I Unit number report file C IERROR INT 1 O Error C C IMPLICIT NONE for extra compiler checks C SAVE to keep the group definition intact C IMPLICIT NONE SAVE C C declaration of arguments C INTEGER SERIAL , LUNREP , + IERROR INTEGER DEFFDS REAL VFFORM , VERSIO CHARACTER*20 RUNDAT CHARACTER*40 FFORM , CONTEN , + SOURCE CHARACTER*40 REMARK(4) C C Local variables C C GRPNAM CHAR*16 1 LOCAL group name (table) C NELEMS INTEGER 1 LOCAL number of elements in group (=cell) C ELMNMS CHAR*16 NELEMS LOCAL name of elements on file C ELMTPS CHAR*16 NELEMS LOCAL type of elements C ELMDMS INTEGER 6,NELEMS LOCAL dimension of elements C NBYTSG INTEGER NELEMS LOCAL length of elements (bytes) C INTEGER NELEMS PARAMETER ( NELEMS = 8 ) C INTEGER I , IELM , + BUFLEN INTEGER ELMDMS(2,NELEMS), NBYTSG(NELEMS), + UINDEX(3) CHARACTER*16 GRPNAM CHARACTER*16 ELMNMS(NELEMS) , ELMTPS(NELEMS) CHARACTER*64 ELMDES(NELEMS) C C External NEFIS Functions C INTEGER GETELS + ,GETELT EXTERNAL GETELS + ,GETELT C C element names C DATA GRPNAM /'FILE_ID'/ DATA + (ELMNMS(I),ELMTPS(I),NBYTSG(I),ELMDMS(1,I),ELMDMS(2,I),ELMDES(I), + I = 1 , NELEMS) +/'FFORM ', 'CHARACTER', 40, 1, 1,'File Format ', + 'VFFORM', 'REAL' , 4, 1, 1,'Version File Format ', + 'CONTEN', 'CHARACTER', 40, 1, 1,'File contents ', + 'VERSIO', 'REAL' , 4, 1, 1,'Version number process library', + 'SERIAL', 'INTEGER' , 4, 1, 1,'File serial number ', + 'RUNDAT', 'CHARACTER', 20, 1, 1,'Creation date ', + 'SOURCE', 'CHARACTER', 40, 1, 1,'Source data ', + 'REMARK', 'CHARACTER', 40, 1, 4,'Remarks '/ C C Read group C C WRITE(LUNREP,*) ' reading GROUP:',GRPNAM UINDEX(1) = 1 UINDEX(2) = 1 UINDEX(3) = 1 C WRITE(LUNREP,*) ' reading ELEMENT:',ELMNMS(1) BUFLEN = NBYTSG(1)*ELMDMS(2,1) IERROR = GETELS (DEFFDS , + GRPNAM , ELMNMS(1), + UINDEX , 1 , + BUFLEN , FFORM ) IF ( IERROR .NE. 0 ) THEN WRITE(LUNREP,*) 'ERROR reading element',ELMNMS(1) WRITE(LUNREP,*) 'ERROR number:',IERROR GOTO 900 ENDIF C WRITE(LUNREP,*) ' reading ELEMENT:',ELMNMS(2) BUFLEN = NBYTSG(2)*ELMDMS(2,2) IERROR = GETELT (DEFFDS , + GRPNAM , ELMNMS(2), + UINDEX , 1 , + BUFLEN , VFFORM ) IF ( IERROR .NE. 0 ) THEN WRITE(LUNREP,*) 'ERROR reading element',ELMNMS(2) WRITE(LUNREP,*) 'ERROR number:',IERROR GOTO 900 ENDIF C WRITE(LUNREP,*) ' reading ELEMENT:',ELMNMS(3) BUFLEN = NBYTSG(3)*ELMDMS(2,3) IERROR = GETELS (DEFFDS , + GRPNAM , ELMNMS(3), + UINDEX , 1 , + BUFLEN , CONTEN ) IF ( IERROR .NE. 0 ) THEN WRITE(LUNREP,*) 'ERROR reading element',ELMNMS(3) WRITE(LUNREP,*) 'ERROR number:',IERROR GOTO 900 ENDIF C WRITE(LUNREP,*) ' reading ELEMENT:',ELMNMS(4) BUFLEN = NBYTSG(4)*ELMDMS(2,4) IERROR = GETELT (DEFFDS , + GRPNAM , ELMNMS(4), + UINDEX , 1 , + BUFLEN , VERSIO ) IF ( IERROR .NE. 0 ) THEN WRITE(LUNREP,*) 'ERROR reading element',ELMNMS(4) WRITE(LUNREP,*) 'ERROR number:',IERROR GOTO 900 ENDIF C WRITE(LUNREP,*) ' reading ELEMENT:',ELMNMS(5) BUFLEN = NBYTSG(5)*ELMDMS(2,5) IERROR = GETELT (DEFFDS , + GRPNAM , ELMNMS(5), + UINDEX , 1 , + BUFLEN , SERIAL ) IF ( IERROR .NE. 0 ) THEN WRITE(LUNREP,*) 'ERROR reading element',ELMNMS(5) WRITE(LUNREP,*) 'ERROR number:',IERROR GOTO 900 ENDIF C WRITE(LUNREP,*) ' reading ELEMENT:',ELMNMS(6) BUFLEN = NBYTSG(6)*ELMDMS(2,6) IERROR = GETELS (DEFFDS , + GRPNAM , ELMNMS(6), + UINDEX , 1 , + BUFLEN , RUNDAT ) IF ( IERROR .NE. 0 ) THEN WRITE(LUNREP,*) 'ERROR reading element',ELMNMS(6) WRITE(LUNREP,*) 'ERROR number:',IERROR GOTO 900 ENDIF C WRITE(LUNREP,*) ' reading ELEMENT:',ELMNMS(7) BUFLEN = NBYTSG(7)*ELMDMS(2,7) IERROR = GETELS (DEFFDS , + GRPNAM , ELMNMS(7), + UINDEX , 1 , + BUFLEN , SOURCE ) IF ( IERROR .NE. 0 ) THEN WRITE(LUNREP,*) 'ERROR reading element',ELMNMS(7) WRITE(LUNREP,*) 'ERROR number:',IERROR GOTO 900 ENDIF C WRITE(LUNREP,*) ' reading ELEMENT:',ELMNMS(8) BUFLEN = NBYTSG(8)*ELMDMS(2,8) IERROR = GETELS (DEFFDS , + GRPNAM , ELMNMS(8), + UINDEX , 1 , + BUFLEN , REMARK ) IF ( IERROR .NE. 0 ) THEN WRITE(LUNREP,*) 'ERROR reading element',ELMNMS(8) WRITE(LUNREP,*) 'ERROR number:',IERROR GOTO 900 ENDIF C 900 CONTINUE RETURN C END