Télécharger k1k2.eso

Retour à la liste

Numérotation des lignes :

  1. C K1K2 SOURCE MAGN 05/02/18 21:15:10 5031
  2. SUBROUTINE K1K2(MELE,MINTE,MINTE1,NBN2,NBN1,NBNN,SWORK,
  3. > KK,KERRE)
  4. C----------------------------------------------------------------------
  5. C
  6. C PASSAGE D'UN SPG DE CHAMELEM VERS UN AUTRE SPG DE DEGRE INFERIEUR ---
  7. C
  8. C----------------------------------------------------------------------
  9. IMPLICIT REAL*8(A-H,O-Z)
  10. -INC CCREEL
  11.  
  12. -INC PPARAM
  13. -INC CCOPTIO
  14. -INC SMINTE
  15. SEGMENT SWORK
  16. REAL*8 VAL1(NBN1),VAL2(NBN2),VALN(NBN2)
  17. REAL*8 SHP1(6,NBN1),SHP2(6,NBN2),XE(3,NBNN)
  18. ENDSEGMENT
  19. SEGMENT/AMOI/(BM(NBN2,NBN1)*D,AM(NBN2,NBN2)*D,VAL3(NBN1)*D)
  20. C
  21. JDIM=KERRE
  22. IF(JDIM.EQ.0) THEN
  23. KERRE=29
  24. RETURN
  25. ENDIF
  26. C
  27. KERRE=0
  28.  
  29. SEGINI AMOI
  30.  
  31. C Verification cas 2D ou 3D
  32. IFR = IFOUR+4
  33. GO TO (81,81,81,81,81,82),IFR
  34. 89 KERRE=29
  35. GO TO 99
  36. 81 IDK=3
  37. GO TO 86
  38. 82 IDK=4
  39. 86 CONTINUE
  40. CCC --- CHAMP SOMMET --> CHAMP CENTRE
  41. IF(NBN2.EQ.1) THEN
  42. VV=0.D0
  43. DO 30 IC=1,MINTE1.SHPTOT(/3)
  44. DO 33 ID=1,IDK
  45. DO 331 IE=1,NBN1
  46. SHP1(ID,IE)=MINTE1.SHPTOT(ID,IE,IC)
  47. 331 CONTINUE
  48. 33 CONTINUE
  49. CALL GTEMRD(XE,SHP1,JDIM,NBN1,DJAC)
  50. DJAC=DJAC*MINTE1.POIGAU(IC)
  51. IF(IFR.EQ.4.OR.IFR.EQ.5) THEN
  52. CALL DISTRR(XE,SHP1,NBNN,RR)
  53. IF(IFR.EQ.4.OR.(IFR.EQ.5.AND.
  54. + NIFOUR.EQ.0)) THEN
  55. DJAC=DJAC*RR*2*XPI
  56. ELSE
  57. DJAC=DJAC*RR*XPI
  58. ENDIF
  59. ENDIF
  60. DO 31 IB=1,NBN1
  61. VAL3(IB)=VAL3(IB)+SHP1(1,IB)*DJAC
  62. VV=VV+SHP1(1,IB)*DJAC
  63. 31 CONTINUE
  64. 30 CONTINUE
  65. WW=0.D0
  66. DO 32 IB=1,NBN1
  67. WW=WW+VAL3(IB)*VAL1(IB)
  68. 32 CONTINUE
  69. VAL2(1)=WW/VV
  70.  
  71. CCC --- CHAMP SOMMET --> CHAMP CENTREP1 ou MSOMMET
  72. ELSE
  73. VV=0.D0
  74. DO 40 IC=1,MINTE1.SHPTOT(/3)
  75. DO 43 ID=1,IDK
  76. DO 431 IE=1,NBN1
  77. SHP1(ID,IE)=MINTE1.SHPTOT(ID,IE,IC)
  78. 431 CONTINUE
  79. DO 432 IE=1,NBN2
  80. SHP2(ID,IE)=SHPTOT(ID,IE,IC)
  81. 432 CONTINUE
  82. 43 CONTINUE
  83. IF (KK.EQ.1) THEN
  84. CALL GTEMRD(XE,SHP1,JDIM,NBNN,DJAC)
  85. DJAC=DJAC*MINTE1.POIGAU(IC)
  86. ELSEIF (KK.EQ.2) THEN
  87. CALL GTEMRD(XE,SHP2,JDIM,NBNN,DJAC)
  88. DJAC=DJAC*POIGAU(IC)
  89. ENDIF
  90. IF(IFR.EQ.4.OR.IFR.EQ.5) THEN
  91. IF (KK.EQ.1) THEN
  92. CALL DISTRR(XE,SHP1,NBNN,RR)
  93. ELSEIF (KK.EQ.2) THEN
  94. CALL DISTRR(XE,SHP2,NBNN,RR)
  95. ENDIF
  96. IF(IFR.EQ.4.OR.(IFR.EQ.5.AND.
  97. + NIFOUR.EQ.0)) THEN
  98. DJAC=DJAC*RR*2*XPI
  99. ELSE
  100. DJAC=DJAC*RR*XPI
  101. ENDIF
  102. ENDIF
  103. C
  104. C CALCUL DE LA MATRICE ET DU SECOND MEMBRE
  105. C
  106. DO 20 IA=1,NBN2
  107. DO 21 IB=1,NBN1
  108. BM(IA,IB)=BM(IA,IB)+SHP1(1,IB)*SHP2(1,IA)*DJAC
  109. 21 CONTINUE
  110. DO 22 IB=1,NBN2
  111. AM(IA,IB)=AM(IA,IB)+SHP2(1,IB)*SHP2(1,IA)*DJAC
  112. 22 CONTINUE
  113. 20 CONTINUE
  114. 40 CONTINUE
  115. C WRITE(6,77883)((BM(I,J),J=1,NBN1),I=1,NBN2)
  116. C77883 FORMAT(' MATRICE BM '/(6(1X,1PE12.5)/))
  117. C WRITE(6,77884)((AM(I,J),J=1,NBN2),I=1,NBN2)
  118. C77884 FORMAT(' MATRICE AM '/(6(1X,1PE12.5)/))
  119. SOM=0.D0
  120. DO 63 IA=1,NBN2
  121. SOM=SOM+AM(IA,IA)
  122. 63 CONTINUE
  123. IF(SOM.EQ.0.D0) THEN
  124. KERRE=358
  125. GO TO 99
  126. ENDIF
  127. PREC=SOM*1.D-40/NBN2
  128. CALL INVALM(AM,NBN2,NBN2,KERRE,PREC)
  129. C WRITE(6,77885)((AM(I,J),J=1,NBN2),I=1,NBN2)
  130. C77885 FORMAT(' MATRICE A-1'/(6(1X,1PE12.5)/))
  131. C
  132. C T{AUTRES} = (inve(A))*B*T{SOMMET}
  133. C
  134. DO 36 IA=1,NBN2
  135. SS=0.
  136. DO 37 IB=1,NBN1
  137. SS=SS+BM(IA,IB)*VAL1(IB)
  138. 37 CONTINUE
  139. VALN(IA)=SS
  140. 36 CONTINUE
  141.  
  142. DO 48 IA=1,NBN2
  143. SS=0.
  144. DO 49 IB=1,NBN2
  145. SS=SS+AM(IA,IB)*VALN(IB)
  146. 49 CONTINUE
  147. VAL2(IA)=SS
  148. 48 CONTINUE
  149. ENDIF
  150.  
  151.  
  152. 99 CONTINUE
  153. SEGSUP AMOI
  154. CC ENDIF
  155. C
  156. RETURN
  157. END
  158.  
  159.  
  160.  
  161.  
  162.  
  163.  
  164.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales