!! 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_TABP4 ( DEFFDS , + NO_PROC_MAX , NO_PROC , + PROC_ID , PROC_NAME , + PROC_FORT , PROC_TRCO , + LUNREP , IERROR ) C C Deltares C C CREATED : june 1999 by Jan van Beek C C FUNCTION : Read TABLE_P4 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 NO_PROC_MAX INT I maximum number of processes C NO_PROC INT I number of processes C PROC_ID CHA*10 NO_PROC I unique process identification C PROC_NAME CHA*50 NO_PROC I process name C PROC_FORT CHA*10 NO_PROC I reference to fortran routine C PROC_TRCO INT NO_PROC I transport code (123) 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 NO_PROC_MAX , NO_PROC , + LUNREP , IERROR INTEGER DEFFDS CHARACTER*10 PROC_ID (NO_PROC_MAX) CHARACTER*50 PROC_NAME (NO_PROC_MAX) CHARACTER*10 PROC_FORT (NO_PROC_MAX) INTEGER PROC_TRCO (NO_PROC_MAX) 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 = 5 ) 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 /'TABLE_P4'/ DATA + (ELMNMS(I),ELMTPS(I),NBYTSG(I),ELMDMS(1,I),ELMDMS(2,I),ELMDES(I), + I = 1 , NELEMS) +/'NO_PROC' ,'INTEGER' , 4,1,1,'number of processes' , + 'PROC_ID' ,'CHARACTER',10,1,0,'unique process identification' , + 'PROC_NAME','CHARACTER',50,1,0,'process name' , + 'PROC_FORT','CHARACTER',10,1,0,'fortran subroutine' , + 'PROC_TRCO','INTEGER' , 4,1,0,'transport code (123)' / 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 = GETELT (DEFFDS , + GRPNAM , ELMNMS(1), + UINDEX , 1 , + BUFLEN , NO_PROC ) IF ( IERROR .NE. 0 ) THEN WRITE(LUNREP,*) 'ERROR reading element',ELMNMS(1) WRITE(LUNREP,*) 'ERROR number:',IERROR GOTO 900 ENDIF IF ( NO_PROC .GT. NO_PROC_MAX ) THEN WRITE(LUNREP,*) 'ERROR reading group',GRPNAM WRITE(LUNREP,*) 'Actual number of processes:',NO_PROC WRITE(LUNREP,*) 'greater than maximum:',NO_PROC_MAX IERROR = 1 GOTO 900 ENDIF C C Set dimension of table C DO IELM = 2 , NELEMS ELMDMS(2,IELM) = NO_PROC ENDDO C WRITE(LUNREP,*) ' reading ELEMENT:',ELMNMS(2) BUFLEN = NBYTSG(2)*ELMDMS(2,2) IERROR = GETELS (DEFFDS , + GRPNAM , ELMNMS(2), + UINDEX , 1 , + BUFLEN , PROC_ID ) 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 , PROC_NAME) 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 = GETELS (DEFFDS , + GRPNAM , ELMNMS(4), + UINDEX , 1 , + BUFLEN , PROC_FORT) 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 , PROC_TRCO) IF ( IERROR .NE. 0 ) THEN WRITE(LUNREP,*) 'ERROR reading element',ELMNMS(5) WRITE(LUNREP,*) 'ERROR number:',IERROR GOTO 900 ENDIF C 900 CONTINUE RETURN C END