1 : C RLEX SOURCE CHAT 05/01/13 03:02:41 5004 2 : SUBROUTINE RLEX(MCHPOI,MCHPO1,MCHPO2,MCHPO3,MTABD) 3 : C 4 : C Subroutine de reconstruction lineaire exacte d'un 5 : C Champoint centre au sommet des elements. 6 : C 7 : C********************************************************* 8 : C 9 : C Cette subroutine est appelee par KLNO 10 : C 11 : C********************************************************* 12 : C 13 : C Date : 27/11/98 14 : C 15 : C Auteur : R. MOREL DRN/DMT/SEMT/TTMF 16 : C 21.01.04 : A. Beccantini correction E/S 17 : C correction 3D 18 : C 19 : C********************************************************* 20 : C 21 : C ENTREES : MCHPO1 : CHPOINT centre contenant la fonction 22 : C 23 : C MCHPO2 : CHPOINT centre contenant le gradient 24 : C 25 : C MCHPO3 : CHPOINT centre contenant le limiteur 26 : C 27 : C MTABD : Table domaine 28 : C 29 : C SORTIE : MCHPOI : CHPOINT sommet contenant la fonction 30 : C 31 : C********************************************************* 32 : IMPLICIT INTEGER(I-N) 33 : -INC CCOPTIO 34 : -INC SMCOORD 35 : -INC SMELEME 36 : POINTEUR MELEMS.MELEME,MELEMC.MELEME 37 : -INC SMCHPOI 38 : -INC SMLENTI 39 : -INC SMLMOTS 40 : C 41 : C**** Variables de CCOPTIO 42 : C 43 : INTEGER IPLLB, IERPER, IERMAX, IERR, INTERR 44 : & ,IOTER, IOLEC, IOIMP, IOCAR, IOACQ 45 : & ,IOPER, IOSGB, IOGRA, IOSAU, IORES 46 : & ,IECHO, IIMPI, IOSPI 47 : & ,IDIM, IFICLE, IPREFI 48 : C & ,MCOORD 49 : & ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE 50 : & ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU 51 : & ,NORINC,NORVAL,NORIND,NORVAD 52 : & ,NUCROU, IPSAUV, IREFOR, ISAFOR 53 : C 54 : C Declaration 55 : C 56 : INTEGER MTABD, INDIC, NBCOMP, IGEOMB 57 : & , JGN, JGM, NSOM, NBSOUS, L, NP, NEL, J, K 58 : & , ISOM, LSOM, NCENT, NK 59 : REAL*8 XC, YC, ZC, FC, GX, GY, GZ, GLIM, XS, YS, ZS 60 : & , DX, DY, DZ, DF, FS 61 : CHARACTER*4 MOT 62 : CHARACTER*8 TYPC 63 : C 64 : C Lecture des maillages de la table domaine 65 : C Verification que les maillages correspondent 66 : C 66 : CALL LEKTAB(MTABD,'SOMMET',MELEMS) 67 : IF(IERR.NE.0)RETURN 67 : CALL LEKTAB(MTABD,'MAILLAGE',MELEME) 68 : IF(IERR.NE.0)RETURN 68 : CALL LEKTAB(MTABD,'CENTRE',MELEMC) 69 : IF(IERR.NE.0)RETURN 70 : C 71 : C**** We chech the geom. support of MCHPOi 72 : C 73 : INDIC = 1 74 : NBCOMP = 1 75 : MOT = 'SCAL' 75 : CALL QUEPOI(MCHPO1, MELEMC, INDIC, NBCOMP, MOT) 76 : IF(IERR.NE.0)RETURN 77 : C 78 : JGN = 4 79 : JGM = IDIM 80 : SEGINI MLMOTS 81 : MLMOTS.MOTS(1) = 'P1DX' 82 : MLMOTS.MOTS(2) = 'P1DY' 83 : IF(IDIM .EQ. 3) MLMOTS.MOTS(3) = 'P1DZ' 83 : CALL QUEPO1(MCHPO2, MELEMC, MLMOTS) 84 : IF(IERR.NE.0)RETURN 85 : SEGSUP MLMOTS 86 : C 87 : INDIC = 1 88 : NBCOMP = 1 89 : MOT = 'P1' 89 : CALL QUEPOI(MCHPO3, MELEMC, INDIC, NBCOMP, MOT) 90 : IF(IERR.NE.0)RETURN 91 : C 92 : C**** We read the function 93 : C 93 : CALL LICHT(MCHPO1,MPOVA1,TYPC,IGEOMB) 94 : C In LICHT, SEGACT MPOVA1 95 : IF(IERR.NE.0)RETURN 96 : C 96 : CALL KRIPAD(MELEMS,MLENTI) 97 : IF(IERR.NE.0)RETURN 98 : C In KRIPAD, SEGINI MLENTI 99 : C 100 : C Lecture du gradient 101 : C 101 : CALL LICHT(MCHPO2,MPOVA2,TYPC,IGEOMB) 102 : C In LICHT, SEGACT MPOVA2 103 : IF(IERR.NE.0) RETURN 104 : C 105 : C Lecture du limiteur 106 : C 106 : CALL LICHT(MCHPO3,MPOVA3,TYPC,IGEOMB) 107 : C In LICHT, SEGACT MPOVA3 108 : C 109 : C Creation du chpoint sommet 110 : C 111 : JGN = 4 112 : JGM = 1 113 : SEGINI MLMOTS 114 : MLMOTS.MOTS(1) = 'SCAL' 115 : TYPC = 'CHPOINT ' 115 : CALL KRCHP1(TYPC, MELEMS, MCHPOI, MLMOTS) 116 : IF(IERR.NE.0) RETURN 117 : SEGSUP MLMOTS 117 : CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOMB) 118 : C In LICHT, SEGACT MPOVAL 119 : IF(IERR.NE.0) RETURN 120 : 121 : NSOM=MPOVAL.VPOCHA(/1) 122 : C MPOVA4 contient le nombre de centre contribuant a un sommet 123 : SEGINI, MPOVA4=MPOVAL 124 : C 125 : CC 126 : C On fait une boucle sur les elements du maillage 127 : C A chaque sommet on ajoute la contribution du centre de 128 : C l'element 129 : C 130 : SEGACT MELEME 131 : SEGACT MELEMC 132 : SEGACT MELEMS 133 : NBSOUS=MELEME.LISOUS(/1) 134 : IF(NBSOUS.EQ.0)NBSOUS=1 135 : C 136 : NK=0 137 : IPT1=MELEME 138 : DO L=1,NBSOUS,1 139 : IF(NBSOUS.NE.1)IPT1=LISOUS(L) 140 : SEGACT IPT1 141 : NP=IPT1.NUM(/1) 142 : NEL=IPT1.NUM(/2) 143 : C 144 : DO J=1,NEL,1 145 : NK=NK+1 146 : NCENT=MELEMC.NUM(1,NK) 147 : C Coordonnee du centre 148 : XC=XCOOR((NCENT-1)*(IDIM+1)+1) 149 : YC=XCOOR((NCENT-1)*(IDIM+1)+2) 150 : ZC=0.0D0 151 : IF (IDIM .EQ. 3) ZC=XCOOR((NCENT-1)*(IDIM+1)+3) 152 : C Valeurs de la fonction sur l'element 153 : FC=MPOVA1.VPOCHA(NK,1) 154 : GX=MPOVA2.VPOCHA(NK,1) 155 : GY=MPOVA2.VPOCHA(NK,2) 156 : GZ=0.0D0 157 : IF (IDIM .EQ. 3) GZ=MPOVA2.VPOCHA(NK,3) 158 : GLIM=MPOVA3.VPOCHA(NK,1) 159 : DO K=1,NP,1 160 : ISOM=IPT1.NUM(K,J) 161 : LSOM=MLENTI.LECT(ISOM) 162 : MPOVA4.VPOCHA(LSOM,1)=MPOVA4.VPOCHA(LSOM,1)+1.0D0 163 : XS=XCOOR((ISOM-1)*(IDIM+1)+1) 164 : YS=XCOOR((ISOM-1)*(IDIM+1)+2) 165 : ZS=0.0D0 166 : IF (IDIM .EQ. 3) ZS=XCOOR((ISOM-1)*(IDIM+1)+3) 167 : DX=XS-XC 168 : DY=YS-YC 169 : DZ=ZS-ZC 170 : DF=(DX*GX+DY*GY+DZ*GZ)*GLIM 171 : FS=FC+DF 172 : MPOVAL.VPOCHA(LSOM,1)=MPOVAL.VPOCHA(LSOM,1)+FS 173 : ENDDO 174 : ENDDO 175 : IF(NBSOUS.NE.1) SEGDES IPT1 176 : ENDDO 177 : C 178 : DO J=1,NSOM,1 179 : MPOVAL.VPOCHA(J,1)=MPOVAL.VPOCHA(J,1)/MPOVA4.VPOCHA(J,1) 180 : ENDDO 181 : C 182 : SEGSUP MLENTI 183 : SEGSUP MPOVA4 184 : C 185 : SEGDES MELEME 186 : SEGDES MELEMC 187 : SEGDES MELEMS 188 : C 189 : SEGDES MPOVAL 190 : SEGDES MPOVA1 191 : SEGDES MPOVA2 192 : SEGDES MPOVA3 193 : C 194 : RETURN 195 : END 196 : 197 : 198 : 199 : 200 :
© Cast3M 2003 - All rights reserved.
Disclaimer