gredelmet_autop.f

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\utils\gretel\gredelmet_autop.f
00002 !
00071                      PROGRAM GREDELMET_AUTOP
00072 !                    ***********************
00073 !
00074 !
00075 !***********************************************************************
00076 ! PARALLEL   V7P0                                   27/03/2014
00077 !***********************************************************************
00078 !
00079 !
00080 !
00081 !
00082 !
00083 !
00084 !
00085 !
00086 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00087 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00088 !
00089       USE BIEF, ONLY : NCSIZE
00090       IMPLICIT NONE
00091       INTEGER LNG,LU
00092       COMMON/INFO/LNG,LU
00093       INTEGER LI
00094 !
00095       CHARACTER(LEN=30) GEO
00096 !
00097       INTEGER ERR
00098       INTEGER NELEM,ECKEN,NDUM,I,J,K,NBV1,NBV2,PARAM(10)
00099       INTEGER NPLAN,NPOIN2
00100       INTEGER NPROC
00101       INTEGER I_S, I_SP, I_LEN
00102       INTEGER IDUM, NPTFR
00103       INTEGER IELM,NELEM2,NELMAX2,NPTFR2,NSEG2,KLOG
00104       INTEGER MAXNVOIS,ISEG
00105       INTEGER IELEM,ND1,ND2,ND3,MBND,IFROM,ITO,IFRM1,ITOP1,KNOLG(1)
00106 !
00107       INTEGER, DIMENSION(:)  , ALLOCATABLE :: NPOIN,IPOBO,NOQ,NSEG
00108       INTEGER, DIMENSION(:,:), ALLOCATABLE :: IKLESA
00109       INTEGER, DIMENSION(:,:), ALLOCATABLE :: NACHB,IFANUM
00110       INTEGER, DIMENSION(:),   ALLOCATABLE :: ISEGF
00111 !
00112 !
00113       REAL   , DIMENSION(:)  , ALLOCATABLE :: XORIG,YORIG
00114       REAL   , DIMENSION(:)  , ALLOCATABLE :: AREA
00115       REAL   , DIMENSION(:,:), ALLOCATABLE :: LENGTH
00116 !
00117       INTEGER, DIMENSION(:,:), ALLOCATABLE :: IKLE       ! IKLE(SIZIKL,*) OU IKLE(NELMAX,*)
00118       INTEGER, DIMENSION(:,:), ALLOCATABLE :: IFABOR     ! IFABOR(NELMAX,*) OU IFABOR(NELMAX2,*)
00119       INTEGER, DIMENSION(:)  , ALLOCATABLE :: NVOIS,IADR ! NVOIS(NPOIN),IADR(NPOIN)
00120 !
00121       INTEGER, DIMENSION(:)  , ALLOCATABLE :: NELBOR,LIHBOR      ! NELBOR(NPTFR),LIHBOR(NPTFR)
00122       INTEGER, DIMENSION(:,:), ALLOCATABLE :: NULONE             ! NULONE(NPTFR,2) OU NULONE(NPTFR)
00123       INTEGER, DIMENSION(:,:), ALLOCATABLE :: KP1BOR             ! KP1BOR(NPTFR,2) OU KP1BOR(NPTFR)
00124       INTEGER, DIMENSION(:)  , ALLOCATABLE :: NBOR               ! NBOR(*)
00125       INTEGER, DIMENSION(:,:), ALLOCATABLE :: IKLBOR             ! IKLBOR(NPTFR,2)
00126       INTEGER, DIMENSION(:)  , ALLOCATABLE :: T3                 ! T3(NPOIN)
00127       INTEGER, DIMENSION(:)  , ALLOCATABLE :: NBOR0,LIHBOR0      ! NBOR0(NPTFR),LIHBOR0(NPTFR)
00128 !
00129       INTEGER, DIMENSION(:,:), ALLOCATABLE :: GLOSEG         ! GLOSEG(MAXSEG,2)
00130       INTEGER, DIMENSION(:,:), ALLOCATABLE :: ELTSEG,ORISEG  ! ELTSEG(NELMAX,*),ORISEG(NELMAX,3)
00131 !
00132       INTEGER, DIMENSION(:)  , ALLOCATABLE :: NODENRS
00133       INTEGER, DIMENSION(:)  , ALLOCATABLE :: IFROM1,ITOPL1
00134 !
00135       REAL RDUM
00136       REAL X2,X3,Y2,Y3,SURFACC,DX,DY
00137 !
00138       LOGICAL IS
00139 !
00140       CHARACTER*30 RES
00141       CHARACTER*50 RESPAR
00142       CHARACTER*11 EXTENS
00143       CHARACTER*30 CONLIM
00144       CHARACTER*7  FILETYPE
00145       EXTERNAL    EXTENS
00146       INTRINSIC MAXVAL
00147 !
00148       LI=5
00149       LU=6
00150       LNG=2
00151 !HW
00152 !JAJ INTRODUCE YOURSELF WITH THE RELEASE DATE
00153 !
00154       WRITE(LU,*) 'I AM GREDELELMET, COUSIN OF GRETEL FROM BAW HAMBURG'
00155       WRITE(LU,*)
00156 !
00157       WRITE (LU, ADVANCE='NO',
00158      &    FMT='(/,'' GLOBAL GEOMETRY FILE: '')')
00159 !      REWIND(LI)
00160       READ(LI,*) GEO
00161       WRITE(LU,*) GEO
00162 !
00163 ! READS FILENAMES AND THE NUMBER OF PROCESSORS / PARTITIONS
00164 !
00165       WRITE (LU, ADVANCE='NO', FMT='(/,'' RESULT FILE: '')')
00166       READ(LI,*) RES
00167       WRITE(LU,*) RES
00168 !
00169       WRITE (LU,ADVANCE='NO',FMT='(/,'' NUMBER OF PROCESSORS: '')')
00170       READ (LI,*) NPROC
00171       WRITE(LU,*) NPROC
00172       INQUIRE (FILE=GEO,EXIST=IS)
00173       IF (.NOT.IS) THEN
00174         WRITE (LU,*) 'FILE DOES NOT EXIST: ', GEO
00175         CALL PLANTE(1)
00176         STOP
00177       END IF
00178 !
00179       I_S  = LEN (RES)
00180       I_SP = I_S + 1
00181       DO I=1,I_S
00182         IF(RES(I_SP-I:I_SP-I) .NE. ' ') EXIT
00183       ENDDO
00184       I_LEN=I_SP - I
00185 !
00186 !     GEOMETRY FILE, READ UNTIL 10 PARAMETERS:
00187 !
00188       OPEN(2,FILE=GEO,FORM='UNFORMATTED',STATUS='OLD',ERR=990)
00189       READ(2,ERR=990)
00190       READ(2,ERR=990) NBV1,NBV2
00191       DO I=1,NBV1+NBV2
00192         READ(2,ERR=990)
00193       ENDDO ! I
00194       GO TO 992
00195 990   WRITE(LU,*) 'ERROR WHEN OPENING OR READING FILE: ',GEO
00196       CALL PLANTE(1)
00197       STOP
00198 992   CONTINUE
00199 !     READS THE 10 PARAMETERS AND THE DATE
00200       READ(2) (PARAM(I),I=1,10)
00201       IF(PARAM(10).EQ.1) READ(2) (PARAM(I),I=1,6)
00202 !
00203 !     RESULTS FILE:
00204 !
00205       OPEN(3,FILE=RES,FORM='UNFORMATTED',ERR=991)
00206       GO TO 993
00207 991   WRITE(LU,*) 'ERROR WHEN OPENING FILE: ',RES
00208       CALL PLANTE(1)
00209       STOP
00210 993   CONTINUE
00211 !
00212 !     1) READS THE BEGINNING OF THE FIRST RESULTS FILE
00213 !
00214 !CC      RESPAR=RES // EXTENS(2**IDIMS-1,0)
00215 !
00216       RESPAR=RES(1:I_LEN) // EXTENS(NPROC-1,0)
00217 !
00218       INQUIRE (FILE=RESPAR,EXIST=IS)
00219       IF (.NOT.IS) THEN
00220         WRITE (LU,*) 'FILE DOES NOT EXIST: ', RESPAR
00221         WRITE (LU,*) 'CHECK THE NUMBER OF PROCESSORS'
00222         WRITE (LU,*) 'AND THE RESULT FILE CORE NAME'
00223         CALL PLANTE(1)
00224         STOP
00225       END IF
00226 !
00227       OPEN(4,FILE=RESPAR,FORM='UNFORMATTED',ERR=994)
00228       GO TO 995
00229 994   WRITE(LU,*) 'ERROR WHEN OPENING FILE: ',RESPAR
00230       CALL PLANTE(1)
00231       STOP
00232 995   CONTINUE
00233 !
00234       READ(4) FILETYPE
00235       READ(4) NPLAN
00236       CLOSE(4)
00237 !
00238 !  5 : 4 PARAMETERS
00239 !
00240       READ(2) NELEM,NPOIN2,ECKEN,NDUM
00241       WRITE(LU,*) '4 PARAMETERS IN GEOMETRY FILE'
00242       WRITE(LU,*) 'NELEM=',  NELEM
00243       WRITE(LU,*) 'NPOIN2=', NPOIN2
00244       WRITE(LU,*) 'ECKEN=',  ECKEN
00245       WRITE(LU,*) 'NDUM=',   NDUM
00246 !
00247 !  DYNAMICALLY ALLOCATES THE ARRAYS
00248 !
00249       ALLOCATE(NPOIN(NPROC),STAT=ERR)
00250       CALL CHECK_ALLOCATE(ERR, 'NPOIN')
00251       ALLOCATE(NOQ(NPROC),STAT=ERR)
00252       CALL CHECK_ALLOCATE(ERR, 'NOQ')
00253       ALLOCATE(NSEG(NPROC),STAT=ERR)
00254       CALL CHECK_ALLOCATE(ERR, 'NSEG')
00255       ALLOCATE(IKLESA(3,NELEM),STAT=ERR)
00256       CALL CHECK_ALLOCATE(ERR, 'IKLESA')
00257       ALLOCATE(IPOBO(NPOIN2)      ,STAT=ERR)
00258       CALL CHECK_ALLOCATE(ERR, 'IPOBO')
00259 !  X AND Y
00260       ALLOCATE(XORIG(NPOIN2)    ,STAT=ERR)
00261       CALL CHECK_ALLOCATE(ERR, 'XORIG')
00262       ALLOCATE(YORIG(NPOIN2)    ,STAT=ERR)
00263       CALL CHECK_ALLOCATE(ERR, 'YORIG')
00264 !
00265       ALLOCATE(IFABOR(NELEM,3),STAT=ERR)
00266       CALL CHECK_ALLOCATE(ERR, 'IFABOR')
00267       ALLOCATE(IKLE(NELEM,3),STAT=ERR)
00268       CALL CHECK_ALLOCATE(ERR, 'IKLE')
00269       ALLOCATE(IADR(NPOIN2),STAT=ERR)
00270       CALL CHECK_ALLOCATE(ERR, 'IADR')
00271       ALLOCATE(NVOIS(NPOIN2),STAT=ERR)
00272       CALL CHECK_ALLOCATE(ERR, 'NVOIS')
00273       ALLOCATE(T3(NPOIN2),STAT=ERR)
00274       CALL CHECK_ALLOCATE(ERR, 'T3')
00275       ALLOCATE(AREA(NPOIN2),STAT=ERR)
00276       CALL CHECK_ALLOCATE(ERR, 'AREA')
00277       ALLOCATE(NODENRS(NPOIN2),STAT=ERR)
00278       CALL CHECK_ALLOCATE(ERR, 'NODENRS')
00279 !
00280 !  END OF ALLOCATION ...
00281 !
00282 !  6 : IKLE
00283 !
00284       READ(2)  ((IKLESA(I,J),I=1,ECKEN),J=1,NELEM)
00285 !
00286 !  7 : IPOBO
00287 !
00288       READ(2)  (IPOBO(I),I=1,NPOIN2)
00289 !
00290 !  8 : X AND Y, WILL BE CHECKED LATER ...
00291 !
00292       READ(2)  (XORIG(I),I=1,NPOIN2)
00293       READ(2)  (YORIG(I),I=1,NPOIN2)
00294 !
00295 !----------------------------------------------------------------------
00296 !
00297 !
00298       IF(NPLAN.LE.1) THEN
00299         CONLIM = "T2DCLI"
00300       ELSE
00301         CONLIM = "T3DCLI"
00302       ENDIF
00303 !
00304       OPEN(4,FILE=CONLIM,FORM='FORMATTED',ERR=996)
00305       GO TO 997
00306  996  WRITE(LU,*) 'ERROR WHEN OPENING FILE: ',CONLIM
00307       CALL PLANTE(1)
00308       STOP
00309  997  CONTINUE
00310 !
00311       ALLOCATE(LIHBOR0(NPOIN2),STAT=ERR)
00312       CALL CHECK_ALLOCATE(ERR, 'LIHBOR')
00313       ALLOCATE(NBOR0(NPOIN2),STAT=ERR)
00314       CALL CHECK_ALLOCATE(ERR, 'NBOR')
00315       DO I=1,NPOIN2
00316         READ(4,*,END=989) LIHBOR0(I),IDUM,IDUM,RDUM,RDUM,RDUM,RDUM,
00317      &                    IDUM,RDUM,RDUM,RDUM,NBOR0(I),IDUM
00318       ENDDO
00319 !
00320       CLOSE(4)
00321  989  NPTFR=I-1
00322 !
00323       ALLOCATE(LIHBOR(NPTFR),STAT=ERR)
00324       CALL CHECK_ALLOCATE(ERR, 'LIHBOR')
00325       ALLOCATE(NBOR(NPTFR),STAT=ERR)
00326       CALL CHECK_ALLOCATE(ERR, 'NBOR')
00327       ALLOCATE(NELBOR(NPTFR),STAT=ERR)
00328       CALL CHECK_ALLOCATE(ERR, 'NELBOR')
00329       ALLOCATE(NULONE(NPTFR,2),STAT=ERR)
00330       CALL CHECK_ALLOCATE(ERR, 'NULONE')
00331       ALLOCATE(KP1BOR(NPTFR,2),STAT=ERR)
00332       CALL CHECK_ALLOCATE(ERR, 'KP1BOR')
00333       ALLOCATE(IKLBOR(NPTFR,2),STAT=ERR)
00334       CALL CHECK_ALLOCATE(ERR, 'IKLBOR')
00335       ALLOCATE(ELTSEG(NELEM,3),STAT=ERR)
00336       CALL CHECK_ALLOCATE(ERR, 'ELTSEG')
00337       ALLOCATE(ORISEG(NELEM,3),STAT=ERR)
00338       CALL CHECK_ALLOCATE(ERR, 'ORISEG')
00339 !
00340       MBND=0
00341 !
00342       DO I=1,NPOIN2
00343         NODENRS(I) = I
00344       ENDDO
00345 !
00346       DO I=1,NPTFR
00347         NBOR(I)   = NBOR0(I)
00348         LIHBOR(I) = LIHBOR0(I)
00349         IF (LIHBOR(I).NE.2) THEN
00350           MBND = MBND + 1
00351           NODENRS(NBOR(I)) = -MBND
00352         ENDIF
00353       ENDDO
00354 !
00355 !------------------------------------------------------------------------------
00356 !
00357 ! LOCAL CONSTRUCTION OF GLOSEG
00358 !
00359 !------------------------------------------------------------------------------
00360 !
00361 !     WITH PRISMS, DIFFERENT FROM 2D VALUES, OTHERWISE
00362 !
00363       IELM = 11 ! WARNING: IS HARD-CODED !!!
00364         NELEM2  =NELEM
00365         NELMAX2 =NELEM
00366         NPTFR2  =NPTFR
00367 !
00368 !     NEIGHBOURS OF THE BOUNDARY SIDES FOR TRIANGULAR MESH
00369 !
00370         DO J=1,NELEM
00371           DO I=1,3
00372             IKLE(J,I)=IKLESA(I,J)
00373           ENDDO
00374         ENDDO
00375       NCSIZE = 1
00376       IF(IELM.EQ.11.OR.IELM.EQ.41.OR.IELM.EQ.51) THEN
00377         ! DUMMY ARRAY
00378         ALLOCATE(NACHB(1,1),STAT=ERR)
00379         CALL CHECK_ALLOCATE(ERR, 'NACHB')
00380 !
00381         CALL VOISIN(IFABOR,NELEM2,NELEM,IELM,IKLE,
00382      &              NELEM,
00383      &              NPOIN2,NACHB,NBOR,NPTFR,IADR,NVOIS)
00384 !
00385         DEALLOCATE(NACHB)
00386         MAXNVOIS = MAXVAL(NVOIS)/2
00387 !
00388       ELSE
00389         WRITE(LU,*) 'UNEXPECTED ELEMENT IN INBIEF:',IELM
00390         CALL PLANTE(1)
00391         STOP
00392       ENDIF
00393       KLOG = 2 ! SOLID BOUNDARY CONDITION: IS HARD-CODED !!!
00394       IF(IELM.EQ.11.OR.IELM.EQ.41.OR.IELM.EQ.51) THEN
00395         ! Dummy arrays
00396         ALLOCATE(IFANUM(1,1),STAT=ERR)
00397         CALL CHECK_ALLOCATE(ERR, 'IFANUM')
00398         ALLOCATE(ISEGF(NPTFR),STAT=ERR)
00399         CALL CHECK_ALLOCATE(ERR, 'ISEG')
00400 !
00401         CALL ELEBD(NELBOR,NULONE,KP1BOR,
00402      &             IFABOR,NBOR,IKLE,NELEM,
00403      &             IKLBOR,NELEM2,NELMAX2,
00404      &             NPOIN2,NPTFR2,IELM,
00405      &             LIHBOR,KLOG,
00406      &             IFANUM,1,ISEGF,
00407      &             IADR,NVOIS,T3,NPTFR2,NPTFR2)
00408 !                                NELEBX, NELEB (HERE EQUAL TO NPTFR2)
00409         DEALLOCATE(IFANUM)
00410         DEALLOCATE(ISEGF)
00411       ELSE
00412         WRITE(LU,*) 'UNEXPECTED ELEMENT IN INBIEF:',IELM
00413         CALL PLANTE(1)
00414         STOP
00415       ENDIF
00416 !
00417 !-----------------------------------------------------------------------
00418 !
00419 !  DATA STRUCTURE FOR EDGE-BASED STORAGE (FROM 5.9 ON ALWAYS DONE IN 2D)
00420 !  SEE CALL TO COMP_SEG BELOW FOR COMPLETING THE STRUCTURE
00421 !
00422       IF(IELM.EQ.11) THEN
00423 !
00424         NSEG2 = (3*NELEM+NPTFR)/2
00425         ALLOCATE(LENGTH(2,NSEG2+MBND),STAT=ERR)
00426         CALL CHECK_ALLOCATE(ERR, 'LENGTH')
00427         ALLOCATE(GLOSEG(NSEG2,2),STAT=ERR)
00428         CALL CHECK_ALLOCATE(ERR, 'GLOSEG')
00429         ALLOCATE(IFROM1(NSEG2),STAT=ERR)
00430         CALL CHECK_ALLOCATE(ERR, 'IFROM1')
00431         ALLOCATE(ITOPL1(NSEG2),STAT=ERR)
00432         CALL CHECK_ALLOCATE(ERR, 'ITOPL1')
00433 !
00434         CALL STOSEG(IFABOR,NELEM,NELMAX2,NELMAX2,IELM,IKLE,
00435      &              NBOR,NPTFR,
00436      &              GLOSEG,NSEG2,    ! GLOSEG%MAXDIM1,
00437      &              ELTSEG,ORISEG,NSEG2,
00438      &              NELBOR,NULONE,KNOLG,IKLBOR,NPTFR ,NPTFR)
00439 !                                              NELENX,NELEB (HERE EQUAL TO NPTFR)
00440       ENDIF
00441 !
00442       IF(FILETYPE(1:6).EQ.'AREA2D') THEN
00443         DO I=1,NPOIN2
00444           AREA(I)=0.D0
00445         ENDDO
00446         DO IELEM=1,NELEM2
00447           ND1 = IKLE(IELEM,1)
00448           ND2 = IKLE(IELEM,2)
00449           ND3 = IKLE(IELEM,3)
00450           X2=XORIG(ND2)-XORIG(ND1)
00451           X3=XORIG(ND3)-XORIG(ND1)
00452           Y2=YORIG(ND2)-YORIG(ND1)
00453           Y3=YORIG(ND3)-YORIG(ND1)
00454           SURFACC=0.5D0*(X2*Y3-X3*Y2)
00455           AREA(ND1)=AREA(ND1)+SURFACC/3.D0
00456           AREA(ND2)=AREA(ND2)+SURFACC/3.D0
00457           AREA(ND3)=AREA(ND3)+SURFACC/3.D0
00458         ENDDO
00459       ELSEIF(FILETYPE(1:6).EQ.'LENGTH') THEN
00460         DO ISEG=1,NSEG2
00461           DX = XORIG(GLOSEG(ISEG,1)) - XORIG(GLOSEG(ISEG,2))
00462           DY = YORIG(GLOSEG(ISEG,1)) - YORIG(GLOSEG(ISEG,2))
00463           LENGTH(1,ISEG) = SQRT(DX**2+DY**2)*0.5D0
00464           LENGTH(2,ISEG) = LENGTH(1,ISEG)
00465         ENDDO
00466         DO I = 1, NPTFR2                    ! LP 05/04/2009
00467           IF (LIHBOR(I).NE.2 ) THEN         ! OPEN BOUNDARY
00468             IFROM = NODENRS(NBOR(I))        ! EXCHANGES ADDED
00469             LENGTH(1,NSEG2-IFROM) = 10.0D0  ! DUMMY LENGTH
00470             LENGTH(2,NSEG2-IFROM) = 10.0D0
00471           ENDIF
00472         ENDDO
00473       ENDIF
00474 !
00475       IF(FILETYPE(1:6).EQ.'AREA2D') THEN
00476         WRITE(3) NPOIN2,0,NPOIN2,NPOIN2,NPOIN2,0
00477         WRITE(3) (REAL(AREA(I)),I=1,NPOIN2)
00478       ELSEIF(FILETYPE(1:6).EQ.'LENGTH') THEN
00479 !        WRITE(3) 0
00480 !        DO K=1,NPLAN
00481 !          WRITE(3) ((REAL(LENGTH(I,J)),I=1,2),J=1,NSEG2+MBND)
00482 !        ENDDO
00483 !        DO K=1,NPLAN-1
00484 !          WRITE(3) (1.0, I=1,NPOIN2*2)
00485 !        ENDDO
00486         WRITE(3) 0,(((REAL(LENGTH(I,J)),I=1,2),J=1,NSEG2+MBND),     ! LP 27/02/2011
00487      &                K=1,NPLAN), ((1.0,1.0), K=1,(NPLAN-1)*NPOIN2) ! BECAUSE OF
00488 !                                                                   ! UNFORMATTED FILES
00489 !                                                                   ! ALL NOW IN 1 RECORD
00490       ELSEIF(FILETYPE(1:6).EQ.'IFRMTO') THEN
00491         DO K=1,NPLAN
00492           DO ISEG=1,NSEG2
00493             IFROM = GLOSEG(ISEG,1)
00494             ITO   = GLOSEG(ISEG,2)
00495             IF ( K.EQ.1 ) THEN
00496               CALL GREDEL_FDNRST(IFROM,ITO,XORIG,YORIG,NODENRS,
00497      &         NPOIN2,IFROM1(ISEG),ITOPL1(ISEG))
00498               IF ( IFROM1(ISEG) .LT. 0 .AND.              !  *START*  LP 24/04/2009
00499      &             IFROM1(ISEG) .NE. NODENRS(IFROM) ) THEN
00500                 DO I = 1,NPOIN2
00501                   IF ( NODENRS(I) .EQ. IFROM1(ISEG) ) THEN
00502                     IFROM1(ISEG) = I
00503                     EXIT
00504                   ENDIF
00505                 ENDDO
00506               ENDIF
00507               IF ( ITOPL1(ISEG) .LT. 0 .AND.
00508      &             ITOPL1(ISEG) .NE. NODENRS(ITO  ) ) THEN
00509                 DO I = 1,NPOIN2
00510                   IF ( NODENRS(I) .EQ. ITOPL1(ISEG) ) THEN
00511                     ITOPL1(ISEG) = I
00512                     EXIT
00513                   ENDIF
00514                 ENDDO
00515               ENDIF                                       !  **END**  LP 24/04/2009
00516             ENDIF
00517             IFRM1 = IFROM1(ISEG)
00518             ITOP1 = ITOPL1(ISEG)
00519             IFROM = IFROM + (K-1)*NPOIN2
00520             IF ( IFRM1 .GT. 0 ) THEN
00521               IFRM1 = IFRM1 + (K-1)*NPOIN2
00522             ELSE
00523               IFRM1 = IFRM1 - (K-1)*MBND                      ! LP 24/04/2009
00524             ENDIF
00525             ITO   = ITO   + (K-1)*NPOIN2
00526             IF ( ITOP1 .GT. 0 ) THEN
00527               ITOP1 = ITOP1 + (K-1)*NPOIN2
00528             ELSE
00529               ITOP1 = ITOP1 - (K-1)*MBND                      ! LP 24/04/2009
00530             ENDIF
00531             WRITE(3) IFROM,ITO,IFRM1,ITOP1
00532           ENDDO
00533           DO I=1,NPTFR2                                      ! LP 05/04/2009
00534             IF ( LIHBOR(I) .NE. 2 ) THEN                       ! OPEN BOUNDARY
00535               IFROM = NODENRS(NBOR(I))                        ! EXCHANGES ADDED
00536               ITO   = NBOR(I)
00537               IFRM1 = IFROM
00538               ITOP1 = ITO
00539               IFROM = IFROM - (K-1)*MBND
00540               IFRM1 = IFRM1 - (K-1)*MBND
00541               ITO   = ITO   + (K-1)*NPOIN2
00542               ITOP1 = ITOP1 + (K-1)*NPOIN2
00543               WRITE(3)IFROM,ITO,IFRM1,ITOP1
00544             ENDIF
00545           ENDDO
00546 !        THE WRITING OF EXCHANGE POINTERS IS CHANGED       **END**     LP 05/04/2009
00547         ENDDO
00548 !
00549 !       DERIVE THE FROM-TO EXCHANGE TABLE FOR COMPUTATIONAL ELEMENTS
00550 !       VERTICALLY FOR ALL LAYERS. THE LAYERS DIFFER NPOIN2 IN
00551 !       COMPUTATIONAL ELEMENT NUMBER. BOUNDARY NODES HAVE NO VERTICAL FLOW
00552 !       WRITE 1.0 FOR THE VERTICAL 'FROM' AND 'TO' HALFDISTANCES
00553 !       THEY ARE UPDATED BY WAQ TO BECOME VOLUME/AREA/2.0 DURING
00554 !       SIMULATION TIME, SINCE VERTICAL DISTANCES CHANGE WITH VOLUME.
00555 !
00556         DO K=1,NPLAN-1
00557           DO I=1,NPOIN2
00558 !       THE WRITING OF EXCHANGE POINTERS IS CHANGED       *START*     LP 05/04/2009
00559             IFROM = I
00560             IFRM1 = IFROM +  MAX(K-2,   0   )*NPOIN2
00561             ITOP1 = IFROM +  MIN(K+1,NPLAN-1)*NPOIN2
00562             IFROM = IFROM + (    K-1        )*NPOIN2
00563             ITO   = IFROM +                      NPOIN2
00564             WRITE (3) IFROM,ITO,IFRM1,ITOP1
00565 !       THE WRITING OF EXCHANGE POINTERS IS CHANGED       **END**     LP 05/04/2009
00566           ENDDO
00567         ENDDO                  ! WAQ COMPUTES THEM ON THE FLY FROM VOLUMES
00568       ENDIF
00569 !
00570       WRITE(LU,*) 'END OF PROGRAM '
00571 !
00572       CLOSE(2)
00573       CLOSE(3)
00574 !
00575       STOP 0
00576       END PROGRAM GREDELMET_AUTOP

Generated on Fri Aug 31 2013 18:12:58 by S.E.Bourban (HRW) using doxygen 1.7.0