!! 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 trase2 ( pmsa , fl , ipoint , increm , noseg , & noflux , iexpnt , iknmrk , noq1 , noq2 , & noq3 , noq4 ) !>\file !> Total of transport in sediment for 66 substances C********************************************************************** C +----------------------------------------+ C | D E L F T H Y D R A U L I C S | C | WAter Resources and Environment | C +----------------------------------------+ C C*********************************************************************** C C Project : Upgrade DELWAQ-G C Author : Jos van Gils C Date : 011224 Version : 0.01 C C History : C C Date Author Description C ------ -------------- ----------------------------------- C ...... .............. .............................. C 011224 Jos van Gils Create first version from TRASED C 021202 Jos van Gils Diffusive transports treated as advection!!! C C*********************************************************************** C C Description of the module : C C Total of TRAnsport processes in the SEDiment C C Name T L I/O Description Units C ---- --- - - ------------------- ----- C Logical Units : - C Modules called : - C Name Type Library C ------ ----- ------------ IMPLICIT REAL (A-H,J-Z) REAL PMSA ( * ) , FL (*) INTEGER IPOINT( * ) , INCREM(*) , NOSEG , NOFLUX, + IEXPNT(4,*) , IKNMRK(*) , NOQ1, NOQ2, NOQ3, NOQ4 C from PMSA array INTEGER :: SWEMERSION ! 3 in switch indicating submersion(0) or emersion (1) INTEGER :: XTRDIF ! 4 in extra diffusion factor in sediment during emersion (-) INTEGER IP1, IP2, IP3, IP4, IP5, IP6, IP7, IP8, IP9, IP10, IP11, IP12 INTEGER IN1, IN2, IN3, IN4, IN5, IN6, IN7, IN8, IN9, IN10, IN11, IN12 REAL FRDISU, FRDOCU, FRDISD, FRDOCD, J FRPAR , VRESU , VSEDI , VBURI , J VBTUR , VBIRR , FRDIS , VSEEP LOGICAL NEWBOT INTEGER IKMRKN, IKMRKV, IVAN , INAAR , IQ IP1 = IPOINT( 1) IP2 = IPOINT( 2) IP3 = IPOINT( 3) IP4 = IPOINT( 4) IP5 = IPOINT( 5) IP6 = IPOINT( 6) IP7 = IPOINT( 7) IP8 = IPOINT( 8) IP9 = IPOINT( 9) IP10 = IPOINT(10) IP11 = IPOINT(11) IP12 = IPOINT(12) C IN1 = INCREM( 1) IN2 = INCREM( 2) IN3 = INCREM( 3) IN4 = INCREM( 4) IN5 = INCREM( 5) IN6 = INCREM( 6) IN7 = INCREM( 7) IN8 = INCREM( 8) IN9 = INCREM( 9) IN10 = INCREM(10) IN11 = INCREM(11) IN12 = INCREM(12) c.....Segmentloop om op nul te zetten c DO 9000 ISEG = 1,NOSEG c 9000 CONTINUE c.....Exchangeloop over de horizontale richtingen om 0 te zetten c.....en over de vertical richting om te initialiseren DO 8000 IQ=1,NOQ1+NOQ2+NOQ3 PMSA(IP11) = 0.0 PMSA(IP12) = 0.0 IP5 = IP5 + IN5 IP6 = IP6 + IN6 IP7 = IP7 + IN7 IP8 = IP8 + IN8 IP9 = IP9 + IN9 IP10 = IP10 + IN10 IP11 = IP11 + IN11 IP12 = IP12 + IN12 8000 CONTINUE c.....Exchangeloop over de verticale richting DO 7000 IQ = NOQ1+NOQ2+NOQ3+1 , NOQ1+NOQ2+NOQ3+NOQ4 IVAN = IEXPNT(1,IQ) INAAR = IEXPNT(2,IQ) C Zoek eerste kenmerk van- en naar-segmenten IF ( IVAN .GT. 0 ) THEN CALL DHKMRK(1,IKNMRK(IVAN ),IKMRKV) ELSE IKMRKV = -1 ENDIF IF ( INAAR .GT. 0 ) THEN CALL DHKMRK(1,IKNMRK(INAAR),IKMRKN) ELSE IKMRKN = -1 ENDIF C extra diffusion during emersion XTRDIF = 1.0 IF ( IVAN .GT. 0 ) THEN SWEMERSION = NINT(PMSA(IP3+(IVAN -1)*IN3)) IF ( SWEMERSION .EQ. 1 ) THEN XTRDIF = PMSA(IP4+(IVAN -1)*IN4) ENDIF ENDIF NEWBOT = .FALSE. IF ( (IKMRKV.EQ.1 .AND. IKMRKN.EQ.3) .OR. + (IKMRKV.EQ.0 .AND. IKMRKN.EQ.3) ) THEN c.....WATER-SEDIMENT INTERFACE FRDISD = PMSA(IP1+(INAAR-1)*IN1) FRDISU = PMSA(IP1+(IVAN -1)*IN1) FRDOCD = PMSA(IP2+(INAAR-1)*IN2) FRDOCU = PMSA(IP2+(IVAN -1)*IN2) NEWBOT = .TRUE. ENDIF IF ( (IKMRKV.EQ.3 .AND. IKMRKN.EQ.3) ) THEN c.....SEDIMENT-SEDIMENT INTERFACE FRDISU = PMSA(IP1+(IVAN -1)*IN1) FRDISD = PMSA(IP1+(INAAR-1)*IN1) FRDOCU = PMSA(IP2+(IVAN -1)*IN2) FRDOCD = PMSA(IP2+(INAAR-1)*IN2) NEWBOT = .TRUE. ENDIF IF (IKMRKV.EQ.3 .AND. IKMRKN.EQ.-1) THEN c.....DEEP SEDIMENT BOUNDARY FRDISU = PMSA(IP1+(IVAN -1)*IN1) FRDISD = FRDISU FRDOCU = PMSA(IP2+(IVAN -1)*IN2) FRDOCD = FRDOCU NEWBOT = .TRUE. ENDIF c Delwaq-G exchange? IF ( NEWBOT ) THEN VRESU = PMSA(IP5) VSEDI = PMSA(IP6) VBURI = PMSA(IP7) VBTUR = PMSA(IP8) VBIRR = PMSA(IP9) VSEEP = PMSA(IP10) VBIRR = VBIRR*XTRDIF c Upward advection FRDIS = FRDISD + FRDOCD FRPAR = 1.0 - FRDIS PMSA(IP11) = (VRESU+MIN(VBTUR,0.0))*FRPAR J + (MIN(VBIRR,0.0)+MIN(VSEEP,0.0))*FRDIS c Downward advection FRDIS = FRDISU + FRDOCU FRPAR = 1.0 - FRDIS PMSA(IP12) = (VSEDI+VBURI+MAX(VBTUR,0.0))*FRPAR J + (MAX(VBIRR,0.0)+MAX(VSEEP,0.0))*FRDIS ENDIF IP5 = IP5 + IN5 IP6 = IP6 + IN6 IP7 = IP7 + IN7 IP8 = IP8 + IN8 IP9 = IP9 + IN9 IP10 = IP10 + IN10 IP11 = IP11 + IN11 IP12 = IP12 + IN12 7000 CONTINUE RETURN END