C PB883 SOURCE CHAT 05/01/13 02:11:02 5004 SUBROUTINE PB883(X,Y,Z,PG,FN,GR,FM,GM,ND,NP,MP,NG,NPG,NOM2) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C************************************************************************ C C CALCULE LES FONCTIONS DE FORME D'UN : Iso-Q2 (iso P1/P0 nc) CU27 C C ^ zeta C | n8______n7 C | / /| C 1 |/_______/ | C |n5| |n6| C | |eta_|__| C | /n4 | /n3 C |/______|/____>ksi C 0 1 C n1 \ n2 C \ C \ C \ C \ C 19__\________18____________17 C / \ / / C / V / / C 20___________26____________/16 C / / / C / / / C /____________/____________/ C 13 14 15 C C 12___________23____________ 11 C / / / C / / / C 24___________27____________/22 C / / / C / / / C /____________/____________/ C 9 21 10 C C 7____________6____________5 C / / / C / / / C 8/___________25____________/4 C / / / C / / / C /____________/____________/ C 1 2 3 C C C C C************************************************************************ CHARACTER*4 NOM2 REAL*8 X(NPG),Y(NPG),Z(NPG) DIMENSION FN(NP,NPG),GR(ND,NP,NPG),PG(NPG) DIMENSION FM(MP,NPG),GM(ND,MP,NPG) DIMENSION U(5),H(5) DIMENSION XX(2,8),YY(2,8),ZZ(2,8) DATA XX/0.D0,0.5D0,0.5D0,1.D0,0.5D0,1.D0,0.D0,0.5D0, & 0.D0,0.5D0,0.5D0,1.D0,0.5D0,1.D0,0.D0,0.5D0/ DATA YY/0.D0,0.5D0,0.D0,0.5D0,0.5D0,1.D0,0.5D0,1.D0, & 0.D0,0.5D0,0.D0,0.5D0,0.5D0,1.D0,0.5D0,1.D0/ DATA ZZ/0.D0,0.5D0,0.D0,0.5D0,0.D0,0.5D0,0.D0,0.5D0, & 0.5D0,1.D0,0.5D0,1.D0,0.5D0,1.D0,0.5D0,1.D0/ C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> CALL CALUHG(U,H,NG) NGG=NG*NG*NG DO 1 K=1,8 C X1=XX(1,K) X2=XX(2,K) Y1=YY(1,K) Y2=YY(2,K) Z1=ZZ(1,K) Z2=ZZ(2,K) K0=(K-1)*NGG CALL CALG3(X1,X2,Y1,Y2,Z1,Z2,NG,H,U,X(K0+1),Y(K0+1),Z(K0+1), & PG(K0+1)) P1C=Y2-Y1 P2C=X1-X2 P3C=Y1-Y2 P4C=X2-X1 P5C=Z2-Z1 P6C=Z1-Z2 C write(6,*)'PiC ' C write(6,1002)P1C,P2C,P3C,P4C,P5C,P6C DO 1 L=1,NGG P1=Y(K0+L)-Y1 P2=X(K0+L)-X2 P3=Y(K0+L)-Y2 P4=X(K0+L)-X1 P5=Z(K0+L)-Z1 P6=Z(K0+L)-Z2 F1C=P2C*P3C*P6C F1=P2*P3*P6/F1C F2C=P3C*P4C*P6C F2=P3*P4*P6/F2C F3C=P4C*P1C*P6C F3=P4*P1*P6/F3C F4C=P1C*P2C*P6C F4=P1*P2*P6/F4C F5C=P2C*P3C*P5C F5=P2*P3*P5/F5C F6C=P3C*P4C*P5C F6=P3*P4*P5/F6C F7C=P4C*P1C*P5C F7=P4*P1*P5/F7C F8C=P1C*P2C*P5C F8=P1*P2*P5/F8C C write(6,*)'FiC' C write(6,1002)F1C,F2C,F3C,F4C,F5C,F6C,F7C,F8C GX1=P3*P6/F1C GY1=P2*P6/F1C GZ1=P2*P3/F1C GX2=P3*P6/F2C GY2=P4*P6/F2C GZ2=P3*P4/F2C GX3=P1*P6/F3C GY3=P4*P6/F3C GZ3=P4*P1/F3C GX4=P1*P6/F4C GY4=P2*P6/F4C GZ4=P1*P2/F4C GX5=P3*P5/F5C GY5=P2*P5/F5C GZ5=P2*P3/F5C GX6=P3*P5/F6C GY6=P4*P5/F6C GZ6=P3*P4/F6C GX7=P1*P5/F7C GY7=P4*P5/F7C GZ7=P4*P1/F7C GX8=P1*P5/F8C GY8=P2*P5/F8C GZ8=P1*P2/F8C C write(6,1002)F1,f2,f3,f4,f5,f6,f7,f8 C C write(6,1002)gx1,gx2,gx3,gx4,gx5,gx6,gx7,gx8 C write(6,1002)gy1,gy2,gy3,gy4,gy5,gy6,gy7,gy8 C write(6,1002)gz1,gz2,gz3,gz4,gz5,gz6,gz7,gz8 LL=K0+L IF(K.EQ.1)THEN FN( 1,LL)=F1 FN( 2,LL)=F2 FN(25,LL)=F3 FN( 8,LL)=F4 FN( 9,LL)=F5 FN(21,LL)=F6 FN(27,LL)=F7 FN(24,LL)=F8 GR(1, 1,LL)=GX1 GR(1, 2,LL)=GX2 GR(1,25,LL)=GX3 GR(1, 8,LL)=GX4 GR(1, 9,LL)=GX5 GR(1,21,LL)=GX6 GR(1,27,LL)=GX7 GR(1,24,LL)=GX8 GR(2, 1,LL)=GY1 GR(2, 2,LL)=GY2 GR(2,25,LL)=GY3 GR(2, 8,LL)=GY4 GR(2, 9,LL)=GY5 GR(2,21,LL)=GY6 GR(2,27,LL)=GY7 GR(2,24,LL)=GY8 GR(3, 1,LL)=GZ1 GR(3, 2,LL)=GZ2 GR(3,25,LL)=GZ3 GR(3, 8,LL)=GZ4 GR(3, 9,LL)=GZ5 GR(3,21,LL)=GZ6 GR(3,27,LL)=GZ7 GR(3,24,LL)=GZ8 ELSEIF(K.EQ.2)THEN FN(2,LL)=F1 FN(3,LL)=F2 FN(4,LL)=F3 FN(25,LL)=F4 FN(21,LL)=F5 FN(10,LL)=F6 FN(22,LL)=F7 FN(27,LL)=F8 GR(1,2,LL)=GX1 GR(1,3,LL)=GX2 GR(1,4,LL)=GX3 GR(1,25,LL)=GX4 GR(1,21,LL)=GX5 GR(1,10,LL)=GX6 GR(1,22,LL)=GX7 GR(1,27,LL)=GX8 GR(2,2,LL)=GY1 GR(2,3,LL)=GY2 GR(2,4,LL)=GY3 GR(2,25,LL)=GY4 GR(2,21,LL)=GY5 GR(2,10,LL)=GY6 GR(2,22,LL)=GY7 GR(2,27,LL)=GY8 GR(3,2,LL)=GZ1 GR(3,3,LL)=GZ2 GR(3,4,LL)=GZ3 GR(3,25,LL)=GZ4 GR(3,21,LL)=GZ5 GR(3,10,LL)=GZ6 GR(3,22,LL)=GZ7 GR(3,27,LL)=GZ8 ELSEIF(K.EQ.3)THEN FN(25,LL)=F1 FN(4,LL)=F2 FN(5,LL)=F3 FN(6,LL)=F4 FN(27,LL)=F5 FN(22,LL)=F6 FN(11,LL)=F7 FN(23,LL)=F8 GR(1,25,LL)=GX1 GR(1,4,LL)=GX2 GR(1,5,LL)=GX3 GR(1,6,LL)=GX4 GR(1,27,LL)=GX5 GR(1,22,LL)=GX6 GR(1,11,LL)=GX7 GR(1,23,LL)=GX8 GR(2,25,LL)=GY1 GR(2,4,LL)=GY2 GR(2,5,LL)=GY3 GR(2,6,LL)=GY4 GR(2,27,LL)=GY5 GR(2,22,LL)=GY6 GR(2,11,LL)=GY7 GR(2,23,LL)=GY8 GR(3,25,LL)=GZ1 GR(3,4,LL)=GZ2 GR(3,5,LL)=GZ3 GR(3,6,LL)=GZ4 GR(3,27,LL)=GZ5 GR(3,22,LL)=GZ6 GR(3,11,LL)=GZ7 GR(3,23,LL)=GZ8 ELSEIF(K.EQ.4)THEN FN(8,LL)=F1 FN(25,LL)=F2 FN(6,LL)=F3 FN(7,LL)=F4 FN(24,LL)=F5 FN(27,LL)=F6 FN(23,LL)=F7 FN(12,LL)=F8 GR(1,8,LL)=GX1 GR(1,25,LL)=GX2 GR(1,6,LL)=GX3 GR(1,7,LL)=GX4 GR(1,24,LL)=GX5 GR(1,27,LL)=GX6 GR(1,23,LL)=GX7 GR(1,12,LL)=GX8 GR(2,8,LL)=GY1 GR(2,25,LL)=GY2 GR(2,6,LL)=GY3 GR(2,7,LL)=GY4 GR(2,24,LL)=GY5 GR(2,27,LL)=GY6 GR(2,23,LL)=GY7 GR(2,12,LL)=GY8 GR(3,8,LL)=GZ1 GR(3,25,LL)=GZ2 GR(3,6,LL)=GZ3 GR(3,7,LL)=GZ4 GR(3,24,LL)=GZ5 GR(3,27,LL)=GZ6 GR(3,23,LL)=GZ7 GR(3,12,LL)=GZ8 ELSEIF(K.EQ.5)THEN FN( 9,LL)=F1 FN(21,LL)=F2 FN(27,LL)=F3 FN(24,LL)=F4 FN(13,LL)=F5 FN(14,LL)=F6 FN(26,LL)=F7 FN(20,LL)=F8 GR(1, 9,LL)=GX1 GR(1,21,LL)=GX2 GR(1,27,LL)=GX3 GR(1,24,LL)=GX4 GR(1,13,LL)=GX5 GR(1,14,LL)=GX6 GR(1,26,LL)=GX7 GR(1,20,LL)=GX8 GR(2, 9,LL)=GY1 GR(2,21,LL)=GY2 GR(2,27,LL)=GY3 GR(2,24,LL)=GY4 GR(2,13,LL)=GY5 GR(2,14,LL)=GY6 GR(2,26,LL)=GY7 GR(2,20,LL)=GY8 GR(3, 9,LL)=GZ1 GR(3,21,LL)=GZ2 GR(3,27,LL)=GZ3 GR(3,24,LL)=GZ4 GR(3,13,LL)=GZ5 GR(3,14,LL)=GZ6 GR(3,26,LL)=GZ7 GR(3,20,LL)=GZ8 ELSEIF(K.EQ.6)THEN FN(21,LL)=F1 FN(10,LL)=F2 FN(22,LL)=F3 FN(27,LL)=F4 FN(14,LL)=F5 FN(15,LL)=F6 FN(16,LL)=F7 FN(26,LL)=F8 GR(1,21,LL)=GX1 GR(1,10,LL)=GX2 GR(1,22,LL)=GX3 GR(1,27,LL)=GX4 GR(1,14,LL)=GX5 GR(1,15,LL)=GX6 GR(1,16,LL)=GX7 GR(1,26,LL)=GX8 GR(2,21,LL)=GY1 GR(2,10,LL)=GY2 GR(2,22,LL)=GY3 GR(2,27,LL)=GY4 GR(2,14,LL)=GY5 GR(2,15,LL)=GY6 GR(2,16,LL)=GY7 GR(2,26,LL)=GY8 GR(3,21,LL)=GZ1 GR(3,10,LL)=GZ2 GR(3,22,LL)=GZ3 GR(3,27,LL)=GZ4 GR(3,14,LL)=GZ5 GR(3,15,LL)=GZ6 GR(3,16,LL)=GZ7 GR(3,26,LL)=GZ8 ELSEIF(K.EQ.7)THEN FN(27,LL)=F1 FN(22,LL)=F2 FN(11,LL)=F3 FN(23,LL)=F4 FN(26,LL)=F5 FN(16,LL)=F6 FN(17,LL)=F7 FN(18,LL)=F8 GR(1,27,LL)=GX1 GR(1,22,LL)=GX2 GR(1,11,LL)=GX3 GR(1,23,LL)=GX4 GR(1,26,LL)=GX5 GR(1,16,LL)=GX6 GR(1,17,LL)=GX7 GR(1,18,LL)=GX8 GR(2,27,LL)=GY1 GR(2,22,LL)=GY2 GR(2,11,LL)=GY3 GR(2,23,LL)=GY4 GR(2,26,LL)=GY5 GR(2,16,LL)=GY6 GR(2,17,LL)=GY7 GR(2,18,LL)=GY8 GR(3,27,LL)=GZ1 GR(3,22,LL)=GZ2 GR(3,11,LL)=GZ3 GR(3,23,LL)=GZ4 GR(3,26,LL)=GZ5 GR(3,16,LL)=GZ6 GR(3,17,LL)=GZ7 GR(3,18,LL)=GZ8 ELSEIF(K.EQ.8)THEN FN(24,LL)=F1 FN(27,LL)=F2 FN(23,LL)=F3 FN(12,LL)=F4 FN(20,LL)=F5 FN(26,LL)=F6 FN(18,LL)=F7 FN(19,LL)=F8 GR(1,24,LL)=GX1 GR(1,27,LL)=GX2 GR(1,23,LL)=GX3 GR(1,12,LL)=GX4 GR(1,20,LL)=GX5 GR(1,26,LL)=GX6 GR(1,18,LL)=GX7 GR(1,19,LL)=GX8 GR(2,24,LL)=GY1 GR(2,27,LL)=GY2 GR(2,23,LL)=GY3 GR(2,12,LL)=GY4 GR(2,20,LL)=GY5 GR(2,26,LL)=GY6 GR(2,18,LL)=GY7 GR(2,19,LL)=GY8 GR(3,24,LL)=GZ1 GR(3,27,LL)=GZ2 GR(3,23,LL)=GZ3 GR(3,12,LL)=GZ4 GR(3,20,LL)=GZ5 GR(3,26,LL)=GZ6 GR(3,18,LL)=GZ7 GR(3,19,LL)=GZ8 ENDIF 1 CONTINUE IF(NOM2.EQ.'MCP0')THEN DO 2 L=1,NPG FM(1,L)=1.D0 GM(1,1,L)=0.D0 GM(2,1,L)=0.D0 GM(3,1,L)=0.D0 2 CONTINUE ELSEIF(NOM2.EQ.'MCP1')THEN DO 3 LL=1,(2*NGG) FM(1,LL)=0.25D0 FM(2,LL+2*NGG)=0.25D0 FM(3,LL+4*NGG)=0.25D0 FM(4,LL+6*NGG)=0.25D0 3 CONTINUE CALL INITD(GM,(12*NPG),0.D0) ELSEIF(NOM2.EQ.'MCF1')THEN DO 4 L=1,NPG FM(1,L)=-(X(L)-1.D0)*(Y(L)-1.D0)*(Z(L)-1.D0) FM(2,L)=X(L)*(Y(L)-1.D0)*(Z(L)-1.D0) FM(3,L)=-X(L)*Y(L)*(Z(L)-1.D0) FM(4,L)=(X(L)-1.D0)*Y(L)*(Z(L)-1.D0) FM(5,L)=(X(L)-1.D0)*(Y(L)-1.D0)*Z(L) FM(6,L)=-X(L)*(Y(L)-1.D0)*Z(L) FM(7,L)=X(L)*Y(L)*Z(L) FM(8,L)=-(X(L)-1.D0)*Y(L)*Z(L) GM(1,1,L)=-(Y(L)-1.D0)*(Z(L)-1.D0) GM(2,1,L)=-(X(L)-1.D0)*(Z(L)-1.D0) GM(3,1,L)=-(X(L)-1.D0)*(Y(L)-1.D0) C GM(1,2,L)=(Y(L)-1.D0)*(Z(L)-1.D0) GM(2,2,L)=X(L)*(Z(L)-1.D0) GM(3,2,L)=X(L)*(Y(L)-1.D0) C GM(1,3,L)=-Y(L)*(Z(L)-1.D0) GM(2,3,L)=-X(L)*(Z(L)-1.D0) GM(3,3,L)=-X(L)*Y(L) C GM(1,4,L)=Y(L)*(Z(L)-1.D0) GM(2,4,L)=(X(L)-1.D0)*(Z(L)-1.D0) GM(3,4,L)=(X(L)-1.D0)*Y(L) C GM(1,5,L)=(Y(L)-1.D0)*Z(L) GM(2,5,L)=(X(L)-1.D0)*Z(L) GM(3,5,L)=(X(L)-1.D0)*(Y(L)-1.D0) C GM(1,6,L)=-(Y(L)-1.D0)*Z(L) GM(2,6,L)=-X(L)*Z(L) GM(3,6,L)=-X(L)*(Y(L)-1.D0) C GM(1,7,L)=Y(L)*Z(L) GM(2,7,L)=X(L)*Z(L) GM(3,7,L)=X(L)*Y(L) C GM(1,8,L)=-Y(L)*Z(L) GM(2,8,L)=-(X(L)-1.D0)*Z(L) GM(3,8,L)=-(X(L)-1.D0)*Y(L) C 4 CONTINUE ENDIF C write(6,*)' VERIF ,PG=' C write(6,1002)(pg(ii),ii=1,npg) C do 75 ll=1,npg C write(6,*)' VERIF ,fn,gr ll=',ll C write(6,1002)(fn(ii,ll),ii=1,np) C write(6,1002)(gr(1,ii,ll),ii=1,np) C write(6,1002)(gr(2,ii,ll),ii=1,np) C write(6,1002)(gr(3,ii,ll),ii=1,np) C write(6,*)' X ' C write(6,1008) x C write(6,*)' Y ' C write(6,1008) y C write(6,*)' GM ' C write(6,*)' Z ' C write(6,1008) Z C write(6,1002) gm C75 continue C write(6,*)' VERIF ,NPG,NP,NGG=',NPG,NP,NGG C UPG=0.D0 C do 72 L=1,NPG C UPG=UPG+PG(L) C UF=0.D0 C UG1=0.D0 C UG2=0.D0 C UG3=0.D0 C DO 71 I=1,NP C UF=UF+FN(I,L) C UG1=UG1+GR(1,I,L) C UG2=UG2+GR(2,I,L) C UG3=UG3+GR(3,I,L) C71 CONTINUE C? WRITE(6,*)' VERIF L=',L,UF,UG1,UG2,UG3 C72 CONTINUE C WRITE(6,*)' VERIF PG=',UPG C WRITE(6,101) RETURN 1002 FORMAT(10(1X,1PD11.4)) 1008 FORMAT( 8(1X,1PD11.4)) 1001 FORMAT(20(1X,I5)) 100 FORMAT(1H1) 101 FORMAT(1X,'... SUB PB883 ... FN,GR,FM,GM ',9(10H..........)/) END