1 : C XCONV SOURCE CHAT 05/01/13 04:13:14 5004 2 : C 3 : SUBROUTINE XCONV(FN,GR,PG,XYZ,HR,PGSQ,RPG,AJ, 4 : & NES,IDIM,NP,NPG,IAXI,AG,AD,IDIV,CMD,IKOMP,LRV, 5 : & WT,WS,HK,PGSK,RPGK,AIRE,AJK,UIL,DUIL,COEFK,ANUK, 6 : & COEF,IKR,UN,NPTU,IPADU,AMU,IKM, 7 : & LE,NBEL,K0,XCOOR, 8 : & AF1,AF2,AF3,AS1,AS2,AS3,NINC,IDCEN,DTM1, 9 : & TN,NPT,IPADT) 10 : IMPLICIT INTEGER(I-N) 11 : IMPLICIT REAL*8 (A-H,O-Z) 12 : C************************************************************************ 13 : C 14 : C CALCUL DE LA MATRICE ELEMENTAIRE DE CONVECTION 15 : C 16 : C 17 : C************************************************************************ 18 : DIMENSION FN(NP,NPG),GR(IDIM,NP,NPG),PG(NPG),XYZ(IDIM,NP) 19 : DIMENSION HR(IDIM,NP,NPG),PGSQ(NPG),RPG(NPG),AJ(IDIM,IDIM,NPG) 20 : DIMENSION LE(NP,NBEL),IPADU(*),IPADT(*) 21 : DIMENSION AF1(NBEL,NP,NP),AS1(NBEL,NP,NP) 22 : DIMENSION AF2(NBEL,NP,NP),AS2(NBEL,NP,NP) 23 : DIMENSION AF3(NBEL,NP,NP),AS3(NBEL,NP,NP) 24 : DIMENSION XCOOR(*) 25 : DIMENSION COEF(1),UN(NPTU,IDIM),AMU(1),TN(NPT,NINC) 26 : 27 : C PARAMETER (LRV1=64,NPX=9,NPGX=9) 28 : DIMENSION WT(LRV,NP,NPG,*),WS(LRV,NP,NPG,*) 29 : DIMENSION HK(LRV,IDIM,NP,NPG) 30 : DIMENSION UIL(LRV,IDIM,NPG),DUIL(LRV,IDIM,NPG) 31 : DIMENSION PGSK(LRV,NPG),RPGK(LRV,NPG),AIRE(LRV) 32 : DIMENSION COEFK(LRV),ANUK(LRV) 33 : DIMENSION AJK(LRV,IDIM,IDIM,NPG) 34 : -INC CCREEL 35 : C*** 36 : C WRITE(6,*)' DEBUT XCONV ',npt,idim,iaxi 37 : C 38 : C 39 : C write(6,*)' IDIV=',IDIV 40 : 41 : DEUPI=1.D0 42 : IF(IAXI.NE.0)DEUPI=2.D0*XPI 43 : 44 : C Calcul du nombre de paquets de LRV éléments 45 : C 46 : NNN=MOD(NBEL,LRV) 47 : IF(NNN.EQ.0) THEN 48 : NPACK=NBEL/LRV 49 : ELSE 50 : NPACK=1+(NBEL-NNN)/LRV 51 : ENDIF 52 : KPACKD=1 53 : KPACKF=NPACK 54 : C 55 : C ******* BOUCLE SUR LES PAQUETS DE LRV ELEMENTS ********** 56 : C 57 : DO 7001 KPACK=KPACKD,KPACKF 58 : C 59 : C ======= A L'INTERIEUR DE CHAQUE PAQUET DE LRV ELEMENTS ======= 60 : C 61 : C 1. Calcul des limites du paquet courant. 62 : KDEB=1+(KPACK-1)*LRV 63 : KFIN=MIN(NBEL,KDEB+LRV-1) 64 : C 65 : DO 7002 K=KDEB,KFIN 66 : KP=K-KDEB+1 67 : NK=K+K0 68 : NKR=(1-IKR)*(NK-1)+1 69 : NKM=(1-IKM)*(NK-1)+1 70 : COEFK(KP)=COEF(NKR) 71 : ANUK(KP)=AMU(NKM)/COEF(NKR) 72 : 7002 CONTINUE 73 : 74 : IF(IDCEN.EQ.2)THEN 75 : 76 : DO 7006 NC=1,NINC 76 : CALL SUPGEF(FN,GR,PG,XYZ,HR,PGSQ,RPG,AJ, 77 : & NES,NP,NPG,IAXI,XCOOR, 78 : & LE,KDEB,KFIN,LRV,IDCEN,CMD,IKOMP, 79 : & TN(1,NC),IPADT,UN,IPADU,NPTU,ANUK, 80 : & WT(1,1,1,NC),WS(1,1,1,NC),HK,PGSK,RPGK,AJK,AIRE,UIL,DUIL, 81 : & DTM1,DT,DTT1,DTT2,DIAEL,NUEL) 82 : 7006 CONTINUE 83 : 84 : ELSE 84 : CALL SUPGEF(FN,GR,PG,XYZ,HR,PGSQ,RPG,AJ, 85 : & NES,NP,NPG,IAXI,XCOOR, 86 : & LE,KDEB,KFIN,LRV,IDCEN,CMD,IKOMP, 87 : & TN,IPADU,UN,IPADU,NPTU,ANUK, 88 : & WT(1,1,1,1),WS(1,1,1,1),HK,PGSK,RPGK,AJK,AIRE,UIL,DUIL, 89 : & DTM1,DT,DTT1,DTT2,DIAEL,NUEL) 90 : ENDIF 91 : 92 : CDIV=0.5D0 93 : IF(IDIV.EQ.0.OR.IKOMP.EQ.1)CDIV=0.D0 94 : 95 : DO 7005 NC=1,NINC 96 : N1=1 97 : IF(IDCEN.EQ.2)N1=NC 98 : 99 : DO 7003 K=KDEB,KFIN 100 : KP=K-KDEB+1 101 : 102 : DO 4 I=1,NP 103 : DO 41 J=1,NP 104 : S1=0.D0 105 : S2=0.D0 106 : DO 5 L=1,NPG 107 : DUL=0.D0 108 : DO 51 N=1,IDIM 109 : DUL=DUL+DUIL(KP,N,L) 110 : 51 CONTINUE 111 : 112 : SN=0.D0 113 : DO 52 N=1,IDIM 114 : SN=SN+(UIL(KP,N,L)*HK(KP,N,J,L)) 115 : 52 CONTINUE 116 : SN=(SN+CDIV*FN(J,L)*DUL)*PGSK(KP,L)*DEUPI*RPGK(KP,L) 117 : S1=S1+SN*WT(KP,I,L,N1) 118 : S2=S2+SN*WS(KP,I,L,N1) 119 : 120 : 5 CONTINUE 121 : IF(NC.EQ.1)THEN 122 : AF1(K,J,I)=S1*COEFK(KP)*AG 123 : AS1(K,J,I)=S2*COEFK(KP)*AD 124 : ELSEIF(NC.EQ.2)THEN 125 : AF2(K,J,I)=S1*COEFK(KP)*AG 126 : AS2(K,J,I)=S2*COEFK(KP)*AD 127 : ELSEIF(NC.EQ.3)THEN 128 : AF3(K,J,I)=S1*COEFK(KP)*AG 129 : AS3(K,J,I)=S2*COEFK(KP)*AD 130 : ENDIF 131 : 132 : 41 CONTINUE 133 : 4 CONTINUE 134 : 7003 CONTINUE 135 : 136 : IF(IKOMP.EQ.1)THEN 137 : 138 : DO 7004 K=KDEB,KFIN 139 : KP=K-KDEB+1 140 : 141 : DO 6 I=1,NP 142 : DO 61 J=1,NP 143 : S1=0.D0 144 : S2=0.D0 145 : DO 7 L=1,NPG 146 : DUL=0.D0 147 : DO 71 N=1,IDIM 148 : DUL=DUL+DUIL(KP,N,L) 149 : 71 CONTINUE 150 : 151 : S1=S1+WT(KP,I,L,N1)*FN(J,L)*DUL 152 : $ *PGSK(KP,L)*DEUPI*RPGK(KP,L) 153 : S2=S2+WS(KP,I,L,N1)*FN(J,L)*DUL 154 : $ *PGSK(KP,L)*DEUPI*RPGK(KP,L) 155 : IF(IAXI.NE.0)THEN 156 : S1=S1+WT(KP,I,L,N1)*FN(J,L)*UIL(KP,1,L)*PGSK(KP,L)*DEUPI 157 : S2=S2+WS(KP,I,L,N1)*FN(J,L)*UIL(KP,1,L)*PGSK(KP,L)*DEUPI 158 : ENDIF 159 : 160 : 161 : 162 : 7 CONTINUE 163 : IF(NC.EQ.1)THEN 164 : AF1(K,J,I)=AF1(K,J,I)+S1*COEFK(KP)*AG 165 : AS1(K,J,I)=AS1(K,J,I)+S2*COEFK(KP)*AD 166 : ELSEIF(NC.EQ.2)THEN 167 : AF2(K,J,I)=AF2(K,J,I)+S1*COEFK(KP)*AG 168 : AS2(K,J,I)=AS2(K,J,I)+S2*COEFK(KP)*AD 169 : ELSEIF(NC.EQ.3)THEN 170 : AF3(K,J,I)=AF3(K,J,I)+S1*COEFK(KP)*AG 171 : AS3(K,J,I)=AS3(K,J,I)+S2*COEFK(KP)*AD 172 : ENDIF 173 : 61 CONTINUE 174 : 6 CONTINUE 175 : 7004 CONTINUE 176 : 177 : ENDIF 178 : 7005 CONTINUE 179 : C 180 : C WRITE(6,*)' FIN XCONV ' 181 : 7001 CONTINUE 182 : RETURN 183 : 1002 FORMAT(10(1X,1PE11.4)) 184 : END 185 : 186 : 187 :
© Cast3M 2003 - All rights reserved.
Disclaimer