C XCONV SOURCE CHAT 05/01/13 04:13:14 5004 C SUBROUTINE XCONV(FN,GR,PG,XYZ,HR,PGSQ,RPG,AJ, & NES,IDIM,NP,NPG,IAXI,AG,AD,IDIV,CMD,IKOMP,LRV, & WT,WS,HK,PGSK,RPGK,AIRE,AJK,UIL,DUIL,COEFK,ANUK, & COEF,IKR,UN,NPTU,IPADU,AMU,IKM, & LE,NBEL,K0,XCOOR, & AF1,AF2,AF3,AS1,AS2,AS3,NINC,IDCEN,DTM1, & TN,NPT,IPADT) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C************************************************************************ C C CALCUL DE LA MATRICE ELEMENTAIRE DE CONVECTION C C C************************************************************************ DIMENSION FN(NP,NPG),GR(IDIM,NP,NPG),PG(NPG),XYZ(IDIM,NP) DIMENSION HR(IDIM,NP,NPG),PGSQ(NPG),RPG(NPG),AJ(IDIM,IDIM,NPG) DIMENSION LE(NP,NBEL),IPADU(*),IPADT(*) DIMENSION AF1(NBEL,NP,NP),AS1(NBEL,NP,NP) DIMENSION AF2(NBEL,NP,NP),AS2(NBEL,NP,NP) DIMENSION AF3(NBEL,NP,NP),AS3(NBEL,NP,NP) DIMENSION XCOOR(*) DIMENSION COEF(1),UN(NPTU,IDIM),AMU(1),TN(NPT,NINC) C PARAMETER (LRV1=64,NPX=9,NPGX=9) DIMENSION WT(LRV,NP,NPG,*),WS(LRV,NP,NPG,*) DIMENSION HK(LRV,IDIM,NP,NPG) DIMENSION UIL(LRV,IDIM,NPG),DUIL(LRV,IDIM,NPG) DIMENSION PGSK(LRV,NPG),RPGK(LRV,NPG),AIRE(LRV) DIMENSION COEFK(LRV),ANUK(LRV) DIMENSION AJK(LRV,IDIM,IDIM,NPG) -INC CCREEL C*** C WRITE(6,*)' DEBUT XCONV ',npt,idim,iaxi C C C write(6,*)' IDIV=',IDIV DEUPI=1.D0 IF(IAXI.NE.0)DEUPI=2.D0*XPI C Calcul du nombre de paquets de LRV éléments C NNN=MOD(NBEL,LRV) IF(NNN.EQ.0) THEN NPACK=NBEL/LRV ELSE NPACK=1+(NBEL-NNN)/LRV ENDIF KPACKD=1 KPACKF=NPACK C C ******* BOUCLE SUR LES PAQUETS DE LRV ELEMENTS ********** C DO 7001 KPACK=KPACKD,KPACKF C C ======= A L'INTERIEUR DE CHAQUE PAQUET DE LRV ELEMENTS ======= C C 1. Calcul des limites du paquet courant. KDEB=1+(KPACK-1)*LRV KFIN=MIN(NBEL,KDEB+LRV-1) C DO 7002 K=KDEB,KFIN KP=K-KDEB+1 NK=K+K0 NKR=(1-IKR)*(NK-1)+1 NKM=(1-IKM)*(NK-1)+1 COEFK(KP)=COEF(NKR) ANUK(KP)=AMU(NKM)/COEF(NKR) 7002 CONTINUE IF(IDCEN.EQ.2)THEN DO 7006 NC=1,NINC CALL SUPGEF(FN,GR,PG,XYZ,HR,PGSQ,RPG,AJ, & NES,NP,NPG,IAXI,XCOOR, & LE,KDEB,KFIN,LRV,IDCEN,CMD,IKOMP, & TN(1,NC),IPADT,UN,IPADU,NPTU,ANUK, & WT(1,1,1,NC),WS(1,1,1,NC),HK,PGSK,RPGK,AJK,AIRE,UIL,DUIL, & DTM1,DT,DTT1,DTT2,DIAEL,NUEL) 7006 CONTINUE ELSE CALL SUPGEF(FN,GR,PG,XYZ,HR,PGSQ,RPG,AJ, & NES,NP,NPG,IAXI,XCOOR, & LE,KDEB,KFIN,LRV,IDCEN,CMD,IKOMP, & TN,IPADU,UN,IPADU,NPTU,ANUK, & WT(1,1,1,1),WS(1,1,1,1),HK,PGSK,RPGK,AJK,AIRE,UIL,DUIL, & DTM1,DT,DTT1,DTT2,DIAEL,NUEL) ENDIF CDIV=0.5D0 IF(IDIV.EQ.0.OR.IKOMP.EQ.1)CDIV=0.D0 DO 7005 NC=1,NINC N1=1 IF(IDCEN.EQ.2)N1=NC DO 7003 K=KDEB,KFIN KP=K-KDEB+1 DO 4 I=1,NP DO 41 J=1,NP S1=0.D0 S2=0.D0 DO 5 L=1,NPG DUL=0.D0 DO 51 N=1,IDIM DUL=DUL+DUIL(KP,N,L) 51 CONTINUE SN=0.D0 DO 52 N=1,IDIM SN=SN+(UIL(KP,N,L)*HK(KP,N,J,L)) 52 CONTINUE SN=(SN+CDIV*FN(J,L)*DUL)*PGSK(KP,L)*DEUPI*RPGK(KP,L) S1=S1+SN*WT(KP,I,L,N1) S2=S2+SN*WS(KP,I,L,N1) 5 CONTINUE IF(NC.EQ.1)THEN AF1(K,J,I)=S1*COEFK(KP)*AG AS1(K,J,I)=S2*COEFK(KP)*AD ELSEIF(NC.EQ.2)THEN AF2(K,J,I)=S1*COEFK(KP)*AG AS2(K,J,I)=S2*COEFK(KP)*AD ELSEIF(NC.EQ.3)THEN AF3(K,J,I)=S1*COEFK(KP)*AG AS3(K,J,I)=S2*COEFK(KP)*AD ENDIF 41 CONTINUE 4 CONTINUE 7003 CONTINUE IF(IKOMP.EQ.1)THEN DO 7004 K=KDEB,KFIN KP=K-KDEB+1 DO 6 I=1,NP DO 61 J=1,NP S1=0.D0 S2=0.D0 DO 7 L=1,NPG DUL=0.D0 DO 71 N=1,IDIM DUL=DUL+DUIL(KP,N,L) 71 CONTINUE S1=S1+WT(KP,I,L,N1)*FN(J,L)*DUL $ *PGSK(KP,L)*DEUPI*RPGK(KP,L) S2=S2+WS(KP,I,L,N1)*FN(J,L)*DUL $ *PGSK(KP,L)*DEUPI*RPGK(KP,L) IF(IAXI.NE.0)THEN S1=S1+WT(KP,I,L,N1)*FN(J,L)*UIL(KP,1,L)*PGSK(KP,L)*DEUPI S2=S2+WS(KP,I,L,N1)*FN(J,L)*UIL(KP,1,L)*PGSK(KP,L)*DEUPI ENDIF 7 CONTINUE IF(NC.EQ.1)THEN AF1(K,J,I)=AF1(K,J,I)+S1*COEFK(KP)*AG AS1(K,J,I)=AS1(K,J,I)+S2*COEFK(KP)*AD ELSEIF(NC.EQ.2)THEN AF2(K,J,I)=AF2(K,J,I)+S1*COEFK(KP)*AG AS2(K,J,I)=AS2(K,J,I)+S2*COEFK(KP)*AD ELSEIF(NC.EQ.3)THEN AF3(K,J,I)=AF3(K,J,I)+S1*COEFK(KP)*AG AS3(K,J,I)=AS3(K,J,I)+S2*COEFK(KP)*AD ENDIF 61 CONTINUE 6 CONTINUE 7004 CONTINUE ENDIF 7005 CONTINUE C C WRITE(6,*)' FIN XCONV ' 7001 CONTINUE RETURN 1002 FORMAT(10(1X,1PE11.4)) END