1 : C HISTOG SOURCE CHAT 11/03/16 21:24:44 6902 2 : SUBROUTINE HISTOG 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : C----------------------------------------------------------------------C 6 : C SUBROUTINE DE L'OPERATEUR "HIST" : C 7 : C C 8 : C OBJ. : L'OPERATEUR 'HIST' RENVOIE UNE EVOLUTION DE TYPE HIS- C 9 : C -TOGRAMME REPRESENTANT LA DENSITE DE DISTRIBUTION DES C 10 : C VALEURS D'UN MCHAML SUR UN MAILLAGE. C 11 : C C 12 : C SYNTHAXE : EV2 = HIST (COUL) MOD1 CHAM1 (ABS) LRE1 |(MOT1 )| ; C 13 : C |(LMOT1)| C 14 : C C 15 : C PRINCIPE : C 16 : C C 17 : C LES INTERVALLES D'ECHANTILLONNAGE DE LA DENSITE DE DISTRIBUTION C 18 : C SONT FOURNIS PAR LE 'LISTREEL' LRE1. DANS LE CAS OU CES INTERVAL-C 19 : C LES NE SONT CONSTANTS, ON REALISE UN HACHAGE EN INTERVALLES REGU-C 20 : C -LIERS DE TAILLE INFERIEURE AU + PETIT INTERVALLE DE LRE1. POUR C 21 : C CHAQUE INTERVALLE, ON MESURE LA LONGUEUR, LA SURFACE OU LE VOLU- C 22 : C -ME DU MAILLAGE ASSOCIE AUX POINTS SUPPORTS DU CHAMP DONT LA VA- C 23 : C -LEUR EST DANS L'INTERVALLE. CETTE MESURE EST DONNEE PAR LE PRO- C 24 : C -DUIT DU POIDS DE GAUSS DU POINT CONSIDERE AVCE LA VALEUR DU JA- C 25 : C -COBIEN EN CE POINT. C 26 : C C 27 : C REMARQUE : C 28 : C C 29 : C UN CHAMP EXPRIME AU NOEUDS EST INTERPOLE AUX POINTS SUPPORTS DES C 30 : C RIGIDITES. POUR LES AUTRES POINTS SUPPORTS, C'EST LE JACOBIEN C 31 : C QUI EST INTERPOLE AUX POINT SUPPORTS DU CHAMP. C 32 : C C 33 : C DESCRIPTION DES VARIABLES D'INTERET DU PROGRAMME : C 34 : C C 35 : C IPMOD1 : POINTEUR SUR MMODEL C 36 : C IPCHE1 : POINTEUR SUR CHAM1 C 37 : C MLREE1 : LISTREEL DES INTERVALLES DE MESURE C 38 : C MLREE2 : ORDONNEES DE LA DENSITE DE DISTRIBUTION C 39 : C LMOT1 : LISTMOTS CONTENANT LE OU LES NOMS DES COMPOSANTES DE C 40 : C CHAM1 A TRAITER C 41 : C N1 : NOMBRE D'INTERVALLES DE MLREE1 C 42 : C X1,X2 : BORNES INF ET SUP DES INTERVALLES D'ECHANTILLONNAGE C 43 : C XPASH : PAS DU HACHAGE C 44 : C NH : NOMBRE D'INTERVALLES DU HACHAGE C 45 : C XINDIC : SEGMENT CONTENANT LES RELATIONS ENTRE LES INTERVALLES C 46 : C DE MLREE1 ET DU HACHAGE 47 : C IPCHE2 : POINTEUR SUR MCHAML DU JACOBIEN ASSOCIE AU MAILLAGE. C 48 : C OBTENU PAR APPEL A JACOPO C 49 : C TZC1 : TABLEAU D'ENTIER, DE DIMENSION LE NOMBRE DE SOUS-ZONE C 50 : C DE CHAM1 x NOMBRE DE COMPOSANTES A TRAITER. CONTIENT C 51 : C LES POINTEURS SUR LES LISTREELS RELATIFS AUX DISTRI- C 52 : C -BUTIONS POUR CHAQUE SOUS-ZONE ET CHAQUE COMPOSANTE C 53 : C NCP2 : NOMBRE DE COMPOSANTES EFFECTIVEMENT TRAITEES C 54 : C LMOT2 : LISTMOTS, NOMS DES COMPOSANTES EFFECTIVEMENT TRAITEES C 55 : C CERTAINS NOMS DE COMPOSANTES SPECIFIES DANS LISMOT1 C 56 : C PEUVENT NE PAS EXISTER DANS CHAM1 C 57 : C MLENT1 : LISTE D'ENTIER DONNANT LES CORRESPONDANCES ENTRE LA C 58 : C Ie COMPOSANTE DU CHAMP ET LA Je COMPOSANTE A TRAITER C 59 : C MLNORM : LISTREEL : MESURE DE LA SOUS-ZONE ASSOCIEE A LA Je C 60 : C COMPOSANTE A TRAITER C 61 : C C 62 : C----------------------------------------------------------------------C 63 : -INC CCOPTIO 64 : -INC CCGEOME 65 : -INC SMELEME 66 : -INC SMCHAML 67 : -INC SMMODEL 68 : -INC SMLMOTS 69 : -INC SMLENTI 70 : -INC SMLREEL 71 : -INC SMEVOLL 72 : -INC SMINTE 73 : C C 74 : C---------------------------- DECLARATIONS ----------------------------C 75 : C C 76 : CHARACTER*4 MCOMP,MCOMPJ,MOTCLE(1) 77 : MOTCLE(1)='ABS ' 78 : C C 79 : SEGMENT XINDIC 80 : INTEGER IIND1(IND1,2) 81 : REAL*8 XIND1(IND1) 82 : ENDSEGMENT 83 : SEGMENT TZC 84 : INTEGER ITZC1(NZ,NC) 85 : ENDSEGMENT 86 : C 87 : POINTEUR MLNORM.MLREEL 88 : C C 89 : C----------------------- ACQUISITION DES ENTREES ----------------------C 90 : C C 91 : C LECTURE OPTIONNELLE DE LA COULEUR : 91 : CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0) 92 : IF (ICOUL.EQ.0) ICOUL=IDCOUL+1 93 : ICOUL=ICOUL-1 94 : C C 95 : C LECTURE OBLIGATOIRE DU MODELE : 96 : MOTERR(1:8)=' MODELE ' 96 : CALL MESLIR(-137) 96 : CALL LIROBJ('MMODEL',IPMOD1,1,IRET) 97 : IF (IERR.NE.0) RETURN 98 : C C 99 : C LECTURE OBLIGATOIRE DU CHAMP : 100 : MOTERR(1:8)=' MCHAML ' 100 : CALL MESLIR(-137) 100 : CALL LIROBJ('MCHAML',IPCHE1,1,IRET) 101 : IF (IERR.NE.0) RETURN 102 : C REDUCTION IPCHE1 SUR IPMOD1 102 : CALL REDUAF(IPCHE1,IPMOD1,IPCHE2,0,IRET,KERRE) 103 : IF (IRET.NE.1) THEN 103 : CALL ERREUR(KERRE) 104 : RETURN 105 : ENDIF 106 : IPCHE1=IPCHE2 107 : C VERIFICATION QUE LES SOUS-ZONES ONT TOUTES MEME SUPPORT 107 : CALL QUESUP(IPMOD1,IPCHE1,0,0,IRET,ISUP1) 108 : IF (ISUP1.EQ.9999) THEN 108 : CALL ERREUR(560) 109 : RETURN 110 : ENDIF 111 : C C 112 : C LECTURE OPTIONNELLE DU MOT-CLE "ABS" : 112 : CALL LIRMOT(MOTCLE,1,IABS,0) 113 : C C 114 : C LECTURE OBLIGATOIRE DU LISTREEL (MLREE1 = INTERVALLES DE MESURE) : 115 : MOTERR(1:8)='LISTREEL' 115 : CALL MESLIR(-137) 115 : CALL LIROBJ('LISTREEL',MLREE1,1,IRET) 116 : IF (IERR.NE.0) RETURN 117 : SEGACT,MLREE1 118 : N1=MLREE1.PROG(/1) 119 : IF (N1.LE.1) THEN 119 : CALL ERREUR(249) 120 : RETURN 121 : ENDIF 122 : X1=MLREE1.PROG(1) 123 : X2=MLREE1.PROG(2) 124 : IF (X1.GE.X2) THEN 124 : CALL ERREUR(249) 125 : RETURN 126 : ENDIF 127 : C CONSTRUCTION D'UN HACHAGE DANS LE CAS OU LONG. INTERV. PAS CONST.: 128 : C 1. RECHERCHE DU + PETIT PAS DANS LISTREEL FOURNI (XPAS) 129 : JG=N1-1 130 : SEGINI,MLREE3 131 : XPAS=X2-X1 132 : MLREE3.PROG(1)=XPAS 133 : DO IH=3,N1 134 : X1=X2 135 : X2=MLREE1.PROG(IH) 136 : XPASI=X2-X1 137 : MLREE3.PROG(IH-1)=XPASI 138 : IF (XPAS.GT.XPASI) XPAS=XPASI 139 : ENDDO 140 : IF (XPAS.LE.0.) THEN 140 : CALL ERREUR(249) 141 : RETURN 142 : ENDIF 143 : C 2. CONSTRUCTION DU HACHAGE (INTERVALLES REGULIERS DE TAILLE 144 : C INFERIEURE AU + PETIT INTERVALLE DE MLREE1) 145 : C XINDIC PERMET D'ASSOCIER LES INTERVALLES DE MLREE1 AU HACHAGE : 146 : C IIND1(I,1)=0 : Ie INTERV. HACHAGE A CHEVAL SUR 2 INTERV. MLREE1 147 : C IIND1(I,1)=1 : Ie INTERV. HACHAGE STRICT. DANS 1 INTERV. MLREE1 148 : C IIND1(I,2)=K : Ie INTERV. HACHAGE ASSOCIE A Ke INTERV. MLREE1 149 : C XIND1(I)= BORNE DES 2 INTERV. MLREE1 DANS Ie INTERV. HACHAGE 150 : C (CAS OU IIND1(I,1)=0) 151 : X1=MLREE1.PROG(1) 152 : NH=INT((X2-X1)/XPAS)+1 153 : IND1=NH 154 : SEGINI,XINDIC 155 : IREF=1 156 : IIND1(1,1)=1 157 : IIND1(1,2)=IREF 158 : XPASH=(X2-X1)/FLOAT(NH) 159 : XREH=X1+XPASH 160 : DO IIND=2,NH 161 : XREF=MLREE1.PROG(IREF+1) 162 : XREH=XREH+XPASH 163 : IIND1(IIND,2)=IREF 164 : XIND1(IIND)=XREF 165 : IF(XREH.GT.XREF) THEN 166 : IIND1(IIND,1)=0 167 : IREF=IREF+1 168 : IF (IREF.GT.N1) THEN 169 : c write(6,*) 'IREF > N1 !!' 170 : RETURN 171 : ENDIF 172 : ELSE 173 : IIND1(IIND,1)=1 174 : ENDIF 175 : ENDDO 176 : C C 177 : C LECTURE OPTIONNELLE DU(DES) NOM(S) DE LA COMPOSANTE A TRAITER : 178 : NCP1=0 179 : C DONNEE D'UN MOT ? 179 : CALL LIRCHA(MCOMP,0,IMOT) 180 : IF (IMOT.NE.0) THEN 181 : NCP1=1 182 : JGM=NCP1 183 : JGN=IMOT 184 : SEGINI,MLMOT1 185 : MLMOT1.MOTS(1)=MCOMP(1:IMOT) 186 : ELSE 187 : C SINON, DONNEE D'UN LISTMOTS ? 187 : CALL LIROBJ('LISTMOTS',MLMOT1,0,IRET) 188 : IF (IRET.NE.0) THEN 189 : SEGACT,MLMOT1 190 : NCP1=MLMOT1.MOTS(/2) 191 : ELSE 192 : C SINON, TOUTES LES COMPOSANTES DU CHAMP EN ENTREE : 193 : C (ATTENTION : IL FAUT PARCOURIR TOUTES LES SOUS-ZONES...) 194 : IMOT=1 195 : MCHEL1=IPCHE1 196 : SEGACT,MCHEL1 197 : NZ1=MCHEL1.ICHAML(/1) 198 : MCHAM1=MCHEL1.ICHAML(1) 199 : SEGACT,MCHAM1 200 : C INITIALISATION MLMOTS SUR 1ERE SOUS-ZONE : 201 : JGN=MCHAM1.NOMCHE(/1) 202 : JGM=MCHAM1.NOMCHE(/2) 203 : SEGINI,MLMOT1 204 : NCP1=JGM 205 : DO I=1,NCP1 206 : MLMOT1.MOTS(I)=MCHAM1.NOMCHE(I) 207 : ENDDO 208 : SEGDES,MCHAM1 209 : C VERIF. NOMS COMPOSANTES SUR LES AUTRES SOUS-ZONES 210 : DO I=2,NZ1 211 : MCHAM1=MCHEL1.ICHAML(I) 212 : SEGACT,MCHAM1 213 : DO J=1,MCHAM1.NOMCHE(/2) 214 : MCOMPJ=MCHAM1.NOMCHE(J) 214 : CALL PLACE(MLMOT1.MOTS,NCP1,IPLA,MCOMPJ) 215 : IF (IPLA.EQ.0) THEN 216 : JGM=NCP1+1 217 : SEGADJ,MLMOT1 218 : NCP1=NCP1+1 219 : MLMOT1.MOTS(NCP1)=MCOMPJ 220 : ENDIF 221 : ENDDO 222 : SEGDES,MCHAM1 223 : ENDDO 224 : SEGDES,MCHEL1 225 : ENDIF 226 : ENDIF 227 : C C 228 : C----------------------------- TRAITEMENT -----------------------------C 229 : C C 230 : C JACOBIEN ASSOCIE AU MODELE : 231 : C CALCUL DU JACOBIEN : 231 : CALL JACOPO(IPMOD1,IPCHE2,IRET) 232 : IF (IRET.EQ.0) RETURN 233 : MMODEL=IPMOD1 234 : SEGACT,MMODEL 235 : IMODEL=KMODEL(1) 236 : SEGACT,IMODEL 237 : C 238 : C AJUSTEMENT DES POINTS SUPPORTS : 239 : C ISUP1 = VALEUR INDICATEUR POINTS SUPPORTS IPCHE1 240 : C ISUP2 = VALEUR INDICATEUR POINTS SUPPORTS IPCHE2 (JACOBIEN) 241 : IF (ISUP1.EQ.1) THEN 241 : CALL CHASUP(IPMOD1,IPCHE1,IPCHE3,IRET,5) 242 : IF (IRET.NE.0) THEN 242 : CALL ERREUR(IRET) 243 : RETURN 244 : ENDIF 245 : IPCHE1=IPCHE3 246 : ELSEIF (ISUP1.NE.5) THEN 246 : CALL CHASUP(IPMOD1,IPCHE2,IPCHE3,IRET,ISUP1) 247 : IF (IRET.NE.0) THEN 247 : CALL ERREUR(IRET) 248 : RETURN 249 : ENDIF 250 : IPCHE2=IPCHE3 251 : ENDIF 252 : C 253 : C ECHANTILLONNAGE : 254 : NCP2=0 255 : MCHEL1=IPCHE1 256 : MCHEL2=IPCHE2 257 : SEGACT,MCHEL1,MCHEL2 258 : NZ1=MCHEL1.ICHAML(/1) 259 : NZ=NZ1 260 : NC=NCP1 261 : SEGINI,TZC 262 : JGN=MLMOT1.MOTS(/1) 263 : JGM=NCP1 264 : SEGINI,MLMOT2 265 : JG=NCP1 266 : SEGINI,MLNORM 267 : SEGINI,MLENT1 268 : DO I=1,NZ1 269 : MCHAM1=MCHEL1.ICHAML(I) 270 : SEGACT,MCHAM1 271 : IPT1=MCHEL1.IMACHE(I) 272 : SEGACT,IPT1 273 : ICOMP=MCHAM1.NOMCHE(/2) 274 : MINTE2=MCHEL2.INFCHE(I,4) 275 : SEGACT,MINTE2 276 : MCHAM2=MCHEL2.ICHAML(I) 277 : SEGACT,MCHAM2 278 : MELVA2=MCHAM2.IELVAL(1) 279 : SEGACT,MELVA2 280 : DO J=1,ICOMP 281 : MCOMPJ=MCHAM1.NOMCHE(J) 281 : CALL PLACE(MLMOT1.MOTS,NCP1,IPLA,MCOMPJ) 282 : IF (IPLA.NE.0) THEN 283 : IF (MCHAM1.TYPCHE(J).NE.'REAL*8') THEN 284 : MOTERR(1:4)='HIST' 285 : MOTERR(5:8)=MCOMPJ(1:4) 285 : CALL ERREUR(335) 286 : RETURN 287 : ENDIF 288 : JREF=IPLA 289 : IPLA=0 289 : IF (NCP2.NE.0) CALL PLACE(MLMOT2.MOTS,NCP2,IPLA,MCOMPJ) 290 : IF (IPLA.EQ.0) THEN 291 : NCP2=NCP2+1 292 : MLMOT2.MOTS(NCP2)=MCOMPJ 293 : MLENT1.LECT(JREF)=NCP2 294 : ENDIF 295 : JG=N1 296 : SEGINI,MLREE2 297 : ITZC1(I,JREF)=MLREE2 298 : MELVA1=MCHAM1.IELVAL(J) 299 : SEGACT,MELVA1 300 : NP1=MELVA1.VELCHE(/1) 301 : NE1=MELVA1.VELCHE(/2) 302 : NP2=MELVA2.VELCHE(/1) 303 : NE2=MELVA2.VELCHE(/2) 304 : DO K=1,IPT1.NUM(/2) 305 : DO L=1,MINTE2.POIGAU(/1) 306 : VIJKL2=MINTE2.POIGAU(L)* 307 : & (ABS(MELVA2.VELCHE(MIN(NP2,L),MIN(NE2,K)))) 308 : XIJKL1=MELVA1.VELCHE(MIN(NP1,L),MIN(NE1,K)) 309 : IF (IABS.EQ.1) XIJKL1=ABS(XIJKL1) 310 : NIJKL1=INT((XIJKL1-X1)/XPASH)+1 311 : IF (NIJKL1.GE.1.AND.NIJKL1.LE.NH.AND.XIJKL1.GE.X1) THEN 312 : IIJKL1=IIND1(NIJKL1,2) 313 : IF (IIND1(NIJKL1,1).EQ.1) THEN 314 : XIJKL2=VIJKL2/MLREE3.PROG(IIJKL1) 315 : MLREE2.PROG(IIJKL1)=MLREE2.PROG(IIJKL1)+XIJKL2 316 : ELSE 317 : IF (XIJKL1.LT.XIND1(NIJKL1)) THEN 318 : XIJKL2=VIJKL2/MLREE3.PROG(IIJKL1) 319 : MLREE2.PROG(IIJKL1)=MLREE2.PROG(IIJKL1)+XIJKL2 320 : ELSE 321 : XIJKL2=VIJKL2/MLREE3.PROG(IIJKL1+1) 322 : MLREE2.PROG(IIJKL1+1)=MLREE2.PROG(IIJKL1+1)+XIJKL2 323 : ENDIF 324 : ENDIF 325 : ENDIF 326 : MLNORM.PROG(JREF)=MLNORM.PROG(JREF)+VIJKL2 327 : ENDDO 328 : ENDDO 329 : SEGDES,MELVA1,MLREE2 330 : ENDIF 331 : ENDDO 332 : SEGDES,MINTE2,MCHAM1,IPT1,MCHAM2,MELVA2 333 : ENDDO 334 : SEGDES,MCHEL1,MCHEL2 335 : C 336 : C VERIFICATION NOMBRE DE COMPOSANTES EFFECTIVEMENT TRAITEES 337 : c write(6,*) 'NCP2 =',NCP2 338 : IF (NCP2.EQ.0) THEN 339 : IF (IMOT.NE.0) THEN 340 : MOTERR(1:4)=MLMOT1.MOTS(1) 341 : MOTERR(5:8)=' ' 341 : CALL ERREUR(77) 342 : RETURN 343 : ELSE 343 : CALL ERREUR(26) 344 : RETURN 345 : ENDIF 346 : ENDIF 347 : IF (NCP2.LT.NCP1) THEN 348 : JGN=MLMOT2.MOTS(/1) 349 : JGM=NCP2 350 : SEGADJ,MLMOT2 351 : ENDIF 352 : SEGSUP,MLREE3 353 : C 354 : C------------------------------- SORTIE -------------------------------C 355 : C C 356 : C CONSTRUCTION DE L'EVOLUTION : 357 : C SOMMATION DES ORDONNEES SUR CHAQUE SOUS-ZONE, 358 : C COMPOSANTE PAR COMPOSANTE : 359 : N=NCP2 360 : SEGINI,MEVOLL 361 : ITYEVO='REEL' 362 : IEVTEX=' ' 363 : DO I=1,NCP1 364 : ICP=MLENT1.LECT(I) 365 : IF (ICP.NE.0) THEN 366 : MLREE2=ITZC1(1,I) 367 : C SOMME SUR LES SOUS-ZONES : 368 : DO J=2,ITZC1(/1) 369 : MLREE3=ITZC1(J,I) 370 : IF (MLREE2.EQ.0) THEN 371 : MLREE2=MLREE3 372 : ELSE 373 : IF (MLREE3.NE.0) THEN 373 : CALL ADLISR(MLREE2,MLREE3,IRET,1) 374 : IF (IRET.EQ.0) RETURN 375 : MLREE2=IRET 376 : ENDIF 377 : ENDIF 378 : ENDDO 379 : C DIVISION DES ORDONNEES PAR XNORM => DENSITE DE DISTRIB. 380 : XNORM=MLNORM.PROG(I) 380 : CALL MUFLIR(MLREE2,XNORM,IRET,-1) 381 : SEGINI,KEVOLL 382 : IPROGX=MLREE1 383 : IPROGY=IRET 384 : TYPX='LISTREEL' 385 : TYPY='LISTREEL' 386 : C COURBE DE TYPE "HIST" POUR TRAITEMENT DANS DESSIN : 387 : NUMEVX=ICOUL 388 : NUMEVY='HIST' 389 : NOMEVX=MLMOT2.MOTS(ICP) 390 : NOMEVY=' ' 391 : SEGDES,KEVOLL 392 : MEVOLL.IEVOLL(ICP)=KEVOLL 393 : ENDIF 394 : ENDDO 395 : SEGDES,MEVOLL,MLREE1 396 : C C 397 : C SORTIE : 397 : CALL ECROBJ('EVOLUTIO',MEVOLL) 398 : C C 399 : C UN PEU DE MENAGE : 400 : IF (IMOT.NE.0) THEN 401 : SEGSUP,MLMOT1 402 : ELSE 403 : SEGDES,MLMOT1 404 : ENDIF 405 : SEGSUP,MLMOT2,TZC,XINDIC,MLNORM,MLENT1 406 : C C 407 : RETURN 408 : END 409 : 410 : 411 : 412 : 413 : 414 : 415 : 416 :
© Cast3M 2003 - All rights reserved.
Disclaimer