1 : C ZCONV SOURCE CHAT 05/01/13 04:21:31 5004 2 : C Attention ! IDIM, IKT, IKU ne servent jamais 3 : C 4 : SUBROUTINE ZCONV(FN,GR,PG,XYZ,HR,PGSQ,RPG, 5 : & NES,IDIM,NP,NPG,IAXI,AIMPL,IKOMP, 6 : & COEF,IKR,UN,IKU,NPTU,IPADU,AMU,IKM, 7 : & LE,NBEL,K0,XCOOR, 8 : & AF1,AF2,AF3,AS1,AS2,AS3,NINC,IDCEN,DTM1, 9 : & TN,IKT,NPT,IPADT,COTE,NELZ) 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) 20 : DIMENSION LE(NP,NBEL),IPADU(*),IPADT(*) 21 : DIMENSION COTE(NELZ,*) 22 : DIMENSION AF1(NBEL,NP,NP),AS1(NBEL,NP,NP) 23 : DIMENSION AF2(NBEL,NP,NP),AS2(NBEL,NP,NP) 24 : DIMENSION AF3(NBEL,NP,NP),AS3(NBEL,NP,NP) 25 : DIMENSION XCOOR(*) 26 : DIMENSION COEF(1),UN(NPTU,IDIM),AMU(1),TN(NPT,NINC) 27 : 28 : PARAMETER (LRV=64,NPX=9,NPGX=9) 29 : DIMENSION WT(LRV,NPX,NPGX),WS(LRV,NPX,NPGX),HK(LRV,3,NPX,NPGX) 30 : DIMENSION PGSK(LRV,NPGX),RPGK(LRV,NPGX),AIRE(LRV) 31 : DIMENSION UMJ(LRV,3,NPGX),DUMJ(LRV,3,NPGX) 32 : DIMENSION COEFK(LRV),ANUK(LRV) 33 : DIMENSION AL(LRV),AH(LRV),AP(LRV) 34 : C*** 35 : C WRITE(IOIMP,*)' DEBUT XCONV ',npt,nelz,idim,iaxi 36 : C 37 : C 38 : C Calcul du nombre de paquets de LRV éléments 39 : C 40 : NNN=MOD(NBEL,LRV) 41 : IF(NNN.EQ.0) THEN 42 : NPACK=NBEL/LRV 43 : ELSE 44 : NPACK=1+(NBEL-NNN)/LRV 45 : ENDIF 46 : KPACKD=1 47 : KPACKF=NPACK 48 : C 49 : C ******* BOUCLE SUR LES PAQUETS DE LRV ELEMENTS ********** 50 : C 51 : DO 7001 KPACK=KPACKD,KPACKF 52 : C 53 : C ======= A L'INTERIEUR DE CHAQUE PAQUET DE LRV ELEMENTS ======= 54 : C 55 : C 1. Calcul des limites du paquet courant. 56 : KDEB=1+(KPACK-1)*LRV 57 : KFIN=MIN(NBEL,KDEB+LRV-1) 58 : C 59 : DO 7002 K=KDEB,KFIN 60 : KP=K-KDEB+1 61 : NK=K+K0 62 : NKR=(1-IKR)*(NK-1)+1 63 : NKM=(1-IKM)*(NK-1)+1 64 : COEFK(KP)=COEF(NKR) 65 : ANUK(KP)=AMU(NKM)/COEF(NKR) 66 : AL(KP)=COTE(NK,1) 67 : AH(KP)=COTE(NK,2) 68 : 7002 CONTINUE 69 : 70 : IF(IDIM.EQ.3)THEN 71 : DO 8002 K=KDEB,KFIN 72 : KP=K-KDEB+1 73 : NK=K+K0 74 : AP(KP)=COTE(NK,3) 75 : 8002 CONTINUE 76 : ENDIF 77 : 78 : DO 7005 NC=1,NINC 79 : 79 : CALL KSUPG(FN,GR,PG,XYZ,HR,PGSQ,RPG, 80 : & NES,NP,NPG,IAXI,XCOOR, 81 : & WT,WS,HK,PGSK,RPGK,AIRE, 82 : & UMJ,DUMJ,KDEB,KFIN,LRV,NPX,NPGX, 83 : & TN(1,NC),IPADT,UN,IPADU,NPTU,NELZ,ANUK, 84 : & IDCEN,LE, 85 : & AL,AH,AP, 86 : & DTM1,DT,DTT1,DTT2,DIAEL,NUEL) 87 : 88 : DO 7003 K=KDEB,KFIN 89 : KP=K-KDEB+1 90 : 91 : DO 4 I=1,NP 92 : DO 41 J=1,NP 93 : S1=0.D0 94 : S2=0.D0 95 : DO 5 L=1,NPG 96 : DO 51 N=1,IDIM 97 : S1=S1+WT(KP,I,L)*UMJ(KP,N,L)*HK(KP,N,J,L) 98 : $ *PGSK(KP,L) 99 : S2=S2+WS(KP,I,L)*UMJ(KP,N,L)*HK(KP,N,J,L) 100 : $ *PGSK(KP,L) 101 : 51 CONTINUE 102 : 5 CONTINUE 103 : IF(NC.EQ.1)THEN 104 : AF1(K,J,I)=S1*COEFK(KP)*AIMPL 105 : AS1(K,J,I)=S2*COEFK(KP)*(AIMPL-1.D0) 106 : ELSEIF(NC.EQ.2)THEN 107 : AF2(K,J,I)=S1*COEFK(KP)*AIMPL 108 : AS2(K,J,I)=S2*COEFK(KP)*(AIMPL-1.D0) 109 : ELSEIF(NC.EQ.3)THEN 110 : AF3(K,J,I)=S1*COEFK(KP)*AIMPL 111 : AS3(K,J,I)=S2*COEFK(KP)*(AIMPL-1.D0) 112 : ENDIF 113 : 114 : 41 CONTINUE 115 : 4 CONTINUE 116 : 7003 CONTINUE 117 : 118 : IF(IKOMP.EQ.1)THEN 119 : 120 : DO 7004 K=KDEB,KFIN 121 : KP=K-KDEB+1 122 : 123 : DO 6 I=1,NP 124 : DO 61 J=1,NP 125 : S1=0.D0 126 : S2=0.D0 127 : DO 7 L=1,NPG 128 : DO 71 N=1,IDIM 129 : S1=S1+WT(KP,I,L)*FN(J,L)*DUMJ(KP,N,L) 130 : $ *PGSK(KP,L) 131 : S2=S2+WS(KP,I,L)*FN(J,L)*DUMJ(KP,N,L) 132 : $ *PGSK(KP,L) 133 : 71 CONTINUE 134 : 7 CONTINUE 135 : IF(NC.EQ.1)THEN 136 : AF1(K,J,I)=AF1(K,J,I)+S1*COEFK(KP)*AIMPL 137 : AS1(K,J,I)=AS1(K,J,I)+S2*COEFK(KP)*(AIMPL-1 138 : $ .D0) 139 : ELSEIF(NC.EQ.2)THEN 140 : AF2(K,J,I)=AF2(K,J,I)+S1*COEFK(KP)*AIMPL 141 : AS2(K,J,I)=AS2(K,J,I)+S2*COEFK(KP)*(AIMPL-1 142 : $ .D0) 143 : ELSEIF(NC.EQ.3)THEN 144 : AF3(K,J,I)=AF3(K,J,I)+S1*COEFK(KP)*AIMPL 145 : AS3(K,J,I)=AS3(K,J,I)+S2*COEFK(KP)*(AIMPL-1 146 : $ .D0) 147 : ENDIF 148 : 61 CONTINUE 149 : 6 CONTINUE 150 : 7004 CONTINUE 151 : 152 : ENDIF 153 : 7005 CONTINUE 154 : C 155 : C WRITE(IOIMP,*)' FIN XCONV ' 156 : 7001 CONTINUE 157 : RETURN 158 : 1002 FORMAT(10(1X,1PE11.4)) 159 : END 160 : 161 : 162 : 163 :
© Cast3M 2003 - All rights reserved.
Disclaimer