cvsp_compress_dp.f

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\sisyphe\cvsp_compress_dp.f
00002 !
00068                       SUBROUTINE CVSP_COMPRESS_DP
00069 !                     ***************************
00070 !
00071      &(J, THRESHOLD)
00072 !
00073 !***********************************************************************
00074 ! SISYPHE   V6P3                                   14/03/2013
00075 !***********************************************************************
00076 !
00077 !
00078 !
00079 !
00080 !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00081 !| J              |<--| INDEX OF A POINT IN MESH
00082 !| THRESHOLD      |<--| SHARE OF A FRACTION WE ARE WILLING TO ROUND OF
00083 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00084 !
00085       USE DECLARATIONS_SISYPHE
00086 !
00087       IMPLICIT NONE
00088       INTEGER LNG,LU
00089       COMMON/INFO/LNG,LU
00090 !
00091 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00092 !
00093       INTEGER,           INTENT(IN)    :: J
00094       DOUBLE PRECISION,  INTENT(IN)    :: THRESHOLD
00095       INTEGER I,K, MARKERMAX, MARKERCNT,  TTT, NNN, JG
00096       INTEGER MAXPOS, M, MARKERMAXOLD, MARKERMAXVERYOLD
00097       INTEGER MARKER(PRO_MAX_MAX), MARKERTEMP(PRO_MAX_MAX)
00098 !
00099 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00100 !
00101 !     USED TO MARK NODES THAT WILL BE KEPT
00102 !
00103       DOUBLE PRECISION LOSS(PRO_MAX_MAX)
00104 !
00105 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00106 ! STORES THE FRACTION ERRORS THAT WILL OCCURE IF THE POINT IS ELEMINATED FROM CURRENT PROFILE
00107 !
00108       DOUBLE PRECISION MAXDIST
00109 !
00110 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00111 ! STORES THE MAXIMUM DISTANCE OF ANY NODE IN THE CURRENT LOOP
00112 !
00113       DOUBLE PRECISION  FI, FJ, FK, DI, DJ, DK, THRESH
00114 !
00115 !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
00116 !
00117       LOGICAL, EXTERNAL:: DB
00118 !
00119 !-----------------------------------------------------------------------
00120 ! PARALLEL: LOCAL TO GLOBAL
00121 !-----------------------------------------------------------------------
00122 !
00123       JG = J
00124       IF (NCSIZE.GT.1) JG = MESH%KNOLG%I(J)
00125 !
00126 !--------------------------------------------------------------------------
00127 ! DEBUG: INIT OUTPUT
00128 !-----------------------------------------------------------------------
00129 !
00130       IF(DB(JG,0)) CALL CVSP_P('./','V_H',JG)
00131 
00132 !--------------------------------------------------------------------------
00133 ! INIT
00134 !-----------------------------------------------------------------------
00135 !
00136       IF(PRO_MAX(J) <= 2) RETURN
00137 !
00138 !-----------------------------------------------------------------------
00139 !FIRST AND LAST POINT WILL ALWAY BE KEPT
00140 !-----------------------------------------------------------------------
00141 !
00142       MARKERMAX = 2             !MAXIMUM USED INDEX IN MARKER ARRAY
00143       MARKER(1) = 1             !FIRST WILL ALWAYS BE KEPT
00144       MARKER(2) = PRO_MAX(J)    !LAST  WILL ALWAYS BE KEPT
00145       MARKERCNT = 1             !MAXIMUM USED INDEX IN MARKERTEMP ARRAY
00146 !
00147       THRESH = THRESHOLD
00148 !
00149 !-------------------------------------------------------------------------
00150 ! EXTEND THRESHOLD IF NECESSARY
00151 !-----------------------------------------------------------------------
00152 !
00153       DO NNN = 1,1              !4
00154         IF (NNN > 1) WRITE(LU,*) 'COMPRESS', J, NNN
00155 !
00156         THRESH = THRESH * (10**(1-NNN))
00157         MARKERMAXVERYOLD = MARKERMAX
00158 !
00159 !--------------------------------------------------------------------------
00160 ! ITERATE UNTIL NOTHING CHANGES ANYMORE
00161 !-----------------------------------------------------------------------
00162 !
00163         DO TTT = 1, PRO_MAX(J) - 2 ! THEROTICAL MAXIMUM NUMBER OF ITERATIONS
00164           MARKERMAXOLD = MARKERMAX
00165           MARKERCNT = 1
00166           MARKERTEMP(MARKERCNT) = 1
00167 !
00168 !--------------------------------------------------------------------------
00169 ! LOOP OVER ALL SECTIONS BETWEEN 2 MARKED NODES
00170 !-----------------------------------------------------------------------
00171 !
00172           DO I = 1, MARKERMAX-1
00173             MAXDIST = 0      !INITS THE MAXIMUM FRACTION ERROR
00174             MAXPOS = -1      !INITS THE NODE WHICH PRODUCES THE MAXIMUM FRACTION ERROR
00175             IF (MARKER(I+1)-MARKER(I) >= 2 ) THEN
00176 !
00177 !--------------------------------------------------------------------------
00178 ! LOOP OVER ALL UNMARKED NODES IN BETWEEN 2 MARKED NODES
00179 !-----------------------------------------------------------------------
00180 !
00181               DO M = MARKER(I) + 1 , MARKER(I + 1) - 1
00182 !
00183 !--------------------------------------------------------------------------
00184 ! HOW MUCH VOLUME=FRACTION IS LOST IF WE ELIMINATE THIS PROFILEPOINT
00185 ! USING "VOLUME" !!! ORIGINAL DOUGLAS-PEUKER: DISTANCE TO INTERCONNECTION !!!
00186 ! "ERROR TRIANGLE VOLUME" IS CALCULATED BY GAUSSIAN POLYGON FORMULA!
00187 !-----------------------------------------------------------------------
00188 !
00189                 LOSS(M) = 0.D0
00190 !
00191                 DO K = 1, NSICLA
00192                   IF (NNN.GE.5) THEN
00193                     FI = PRO_F(J,M-1,K)
00194                     FJ = PRO_F(J,M+1,K)
00195                     FK = PRO_F(J,M,K)
00196                     DI = PRO_D(J,M-1,K)
00197                     DJ = PRO_D(J,M+1,K)
00198                     DK = PRO_D(J,M,K)
00199                   ELSE
00200                     FI = PRO_F(J,MARKER(I),K)
00201                     FJ = PRO_F(J,MARKER(I+1),K)
00202                     FK = PRO_F(J,M,K)
00203                     DI = PRO_D(J,MARKER(I),K)
00204                     DJ = PRO_D(J,MARKER(I+1),K)
00205                     DK = PRO_D(J,M,K)
00206                   ENDIF
00207 !
00208                   LOSS(M) = LOSS(M) +
00209      &                 ABS(0.5D0 * ((FI+FJ) * (DI-DJ) +
00210      &                 (FJ+FK) * (DJ-DK) +
00211      &                 (FK+FI) * (DK-DI)))
00212 
00213                 ENDDO      !K
00214 !
00215                 IF(LOSS(M).GT.MAXDIST) THEN
00216                   MAXDIST = LOSS(M)
00217                   MAXPOS = M
00218                 ENDIF
00219 !
00220               ENDDO         !M
00221 !
00222 !-----------------------------------------------------------------------
00223 ! IF ANY POINT IS TO FAR OUT OF RANGE: ADD IT TO THE MARKER LIST
00224 !-----------------------------------------------------------------------
00225 !
00226               IF(MAXPOS > -1 .AND. MAXDIST > THRESH) THEN
00227                 MARKERCNT = MARKERCNT + 1
00228                 MARKERTEMP(MARKERCNT) = MAXPOS
00229               ENDIF
00230 
00231             ENDIF
00232 !
00233 !-----------------------------------------------------------------------
00234 ! ADD THE ENDPOINT OF THIS SECTION
00235 !-----------------------------------------------------------------------
00236 !
00237             MARKERCNT = MARKERCNT + 1
00238             MARKERTEMP(MARKERCNT) = MARKER(I+1)
00239 !
00240           ENDDO               !I
00241 !
00242           DO I = 1, MARKERCNT
00243             MARKER(I) = MARKERTEMP(I)
00244           ENDDO
00245           MARKERMAX = MARKERCNT
00246 !
00247           IF (MARKERMAX - MARKERMAXOLD == 0 ) EXIT !STOP ITERATION, AS NOTHING CHANGED!
00248         ENDDO                  ! TTT
00249         IF (MARKERMAX - MARKERMAXVERYOLD == 0 ) EXIT !STOP ITERATION, AS NOTHING CHANGED!
00250       ENDDO                     ! NNN
00251 !
00252 !--------------------------------------------------------------------------
00253 ! RECREATE THE SORTING PROFILE WITH LESSER NUMBER OF SECTIONS
00254 !-----------------------------------------------------------------------
00255 !
00256       DO K = 1, NSICLA
00257         DO I = 1, MARKERMAX
00258           PRO_F(J,I,K) = PRO_F(J,MARKER(I),K)
00259           PRO_D(J,I,K) = PRO_D(J,MARKER(I),K)
00260         ENDDO                  !I
00261       ENDDO                     !K
00262 !
00263       PRO_MAX(J) = MARKERMAX
00264 !
00265 !--------------------------------------------------------------------------
00266 ! BRUTFORCE COMPRESSION IN CASE OF EXCEPTIONAL FRAGMENTATION
00267 !-----------------------------------------------------------------------
00268 !
00269       IF(PRO_MAX(J) > PRO_MAX_MAX-4*NSICLA-4) THEN
00270         WRITE(LU,*) 'CVSP_COMPRESS_DP RESIGNS AND CALLS COMPRESS_BRUT:'
00271         CALL CVSP_COMPRESS_BRUT(J)
00272       ENDIF
00273 !
00274 !--------------------------------------------------------------------------
00275 ! DEBUG: FINAL OUTPUT
00276 !-----------------------------------------------------------------------
00277 !
00278       IF(DB(JG,0)) CALL CVSP_P('./','V_I',JG)
00279 !
00280 !-----------------------------------------------------------------------
00281 !
00282       RETURN
00283       END SUBROUTINE CVSP_COMPRESS_DP

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