Télécharger kremp2.eso

Retour à la liste

Numérotation des lignes :

  1. C KREMP2 SOURCE CHAT 05/01/13 01:06:22 5004
  2. SUBROUTINE KREMP2 (K1,K2,O1,A2,C,U2,SHC2D,SKBUF2,SKRESO)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C
  6. C DIM 2 INTERIEUR D'UN CONTOUR
  7. C ------------------------------
  8. C
  9. C-----------------------------------------------------------------------
  10. SEGMENT SKRESO
  11. INTEGER KFC,NRES,KES,KIMP
  12. ENDSEGMENT
  13. C KFC : NOMBRE DE FACES H.C
  14. C NRES: RESOLUTION
  15. C KES : DIM ESPACE
  16. C KIMP: IMPRESSION
  17. C-----------------------------------------------------------------------
  18. C-----------------------------------------------------------------------
  19. SEGMENT SHC2D
  20. INTEGER IR(NR),KA(NFC),IM(NFC,NFC)
  21. INTEGER KRO(NFC,NES),KSI(NFC,NES)
  22. REAL*8 V(NES,NR),G(NR)
  23. ENDSEGMENT
  24.  
  25. C DESCRIPTION DU H.C DE PROJECTION
  26. C --------------------------------
  27. C V : DIRECTION UNITAIRE DES CELLULES
  28. C G : FACTEUR DE FORME ASSOCIE
  29. C IR: CORRESPONDANCE
  30. C KRO , KSI : POUR LE CHANGEMENT DE REPERE
  31. C IM : REFERENCE
  32. C NR : RESOLUTION
  33. C NFC : NOMBRE DE FACES
  34. C-----------------------------------------------------------------------
  35. C-----------------------------------------------------------------------
  36. SEGMENT SKBUF2
  37. INTEGER NUMF(NFC,NOC,NR),NTYP(NFC,NR)
  38. REAL*8 ZB(NFC,NR),PSC(NFC,NR)
  39. ENDSEGMENT
  40. C
  41. C BUFFER ASSOCIE AU H.C
  42. C ---------------------
  43. C NUMF : INDICE DE LE DERNIERE FACE RENCONTREE
  44. C NTYP : TYPES ASSOCIES
  45. C ZB : PROFONDEUR
  46. C PSC : PRODUIT SCALAIRE (NORMALE.DIRECTION CELLULE)
  47. C-----------------------------------------------------------------------
  48. DIMENSION O1(2),X1(2),X2(2),U2(1)
  49. DIMENSION X(2),XR(2),XR1(2),XR2(2)
  50. DIMENSION A2(2,2)
  51. C
  52. DO 100 K=1,2
  53. X1(K)=A2(K,1)
  54. X2(K)=A2(K,2)
  55. 100 CONTINUE
  56. C
  57. IF (KIMP.GE.4) WRITE(6,*) ' X1 ',X1(1),X1(2),' X2 ',X2(1),X2(2)
  58. C
  59. C PROJECTION DES 2 SOMMETS
  60. C
  61. CALL KAPCU2(KES,X1,O1,NRES,XR1,NF1,LS1)
  62. IF (KIMP.GE.4) WRITE(6,*) ' NF1 LS1 XR1 ',NF1,LS1,XR1(1),XR1(2)
  63.  
  64. CALL KAPCU2(KES,X2,O1,NRES,XR2,NF2,LS2)
  65. IF (KIMP.GE.4) WRITE(6,*) ' NF2 LS2 XR2 ',NF2,LS2,XR2(1),XR2(2)
  66.  
  67. CALL KREMS2(K2,NF1,LS1,C,U2,SHC2D,SKBUF2,SKRESO)
  68. CALL KREMS2(K2,NF2,LS2,C,U2,SHC2D,SKBUF2,SKRESO)
  69. C
  70. IF(NF1.EQ.NF2) THEN
  71. C
  72. C UNE SEULE FACE
  73. C --------------
  74. LMIN = MIN0(LS1,LS2)
  75. LMAX = MAX0(LS1,LS2)
  76. IF((LMAX-LMIN).GE.2 ) THEN
  77. CALL K2EMPI(K2,NF1,LMIN+1,LMAX-1,C,U2,SHC2D,SKBUF2,SKRESO)
  78. ENDIF
  79.  
  80. ELSE
  81. C
  82. C DEUX FACES DIFFERENTES 1) PARALLELES 2) NON PARALLELES
  83. C ---------------------------------------------------------
  84. IF (KA(NF1).EQ.KA(NF2)) THEN
  85. IF (KIMP.GE.4) WRITE(6,*) ' KREMP2 CAS PARALLELE'
  86. KAC = KA(NF1)
  87. DO 1 K=1,KES
  88. X(K) = (X1(K)+X2(K))/2
  89. 1 CONTINUE
  90. IF(KIMP.GE.4) WRITE(6,*) ' X ',X(1),X(2)
  91.  
  92. II = 0
  93. 10 CONTINUE
  94. II = II + 1
  95.  
  96. IF (II.GE.12) THEN
  97. WRITE(6,*) ' non convergence de la dichotomie'
  98. RETURN
  99. ELSEIF (II.GE.10) THEN
  100.  
  101. IF((NF1.EQ.1).OR.(NF1.EQ.2)) X(1)=O1(1)
  102. IF((NF1.EQ.3).OR.(NF1.EQ.4)) X(2)=O1(2)
  103.  
  104. ENDIF
  105.  
  106. CALL KAPC21(KES,X,O1,NRES,XR,NF,LS,KAC)
  107.  
  108. IF (NF.EQ.NF1) THEN
  109.  
  110. DO 2 K = 1,KES
  111. X(K) = (X(K)+X2(K))/2
  112. 2 CONTINUE
  113. GOTO 10
  114. ELSE
  115. IF(NF.EQ.NF2) THEN
  116. DO 3 K = 1,KES
  117. X(K) = (X1(K)+X(K))/2
  118. 3 CONTINUE
  119. GOTO 10
  120. ELSE
  121. IF (KIMP.GE.4) WRITE(6,*) ' FACE GENEREE ',NF
  122. C
  123. C NF EST <> NF1 ET <>NF2
  124. C
  125. C ---
  126. LEX = IM(NF1,NF)
  127. IF (LEX.EQ.0) THEN
  128. WRITE(6,*) ' PB FACES ',K1,' ',K2,' CAS 1'
  129. ENDIF
  130. KELT = LEX-LS1
  131. IF (KELT.GE.1 ) THEN
  132. CALL K2EMPI(K2,NF1,LS1+1,LEX,C,U2,SHC2D,SKBUF2,SKRESO)
  133. ENDIF
  134. IF (KELT.LE.-1) THEN
  135. CALL K2EMPI(K2,NF1,LEX,LS1+1,C,U2,SHC2D,SKBUF2,SKRESO)
  136. ENDIF
  137.  
  138. LEX = IM(NF2,NF)
  139. IF (LEX.EQ.0) THEN
  140. WRITE(6,*) ' PB FACES ',K1,' ',K2,' CAS 2'
  141. ENDIF
  142. KELT = LEX-LS2
  143. IF (KELT.GE.1 ) THEN
  144. CALL K2EMPI(K2,NF2,LS2+1,LEX,C,U2,SHC2D,SKBUF2,SKRESO)
  145. ENDIF
  146. IF (KELT.LE.-1) THEN
  147. CALL K2EMPI(K2,NF2,LEX,LS2+1,C,U2,SHC2D,SKBUF2,SKRESO)
  148. ENDIF
  149.  
  150. CALL K2EMPI(K2,NF,1,NRES,C,U2,SHC2D,SKBUF2,SKRESO)
  151. C
  152. ENDIF
  153. ENDIF
  154. C
  155. ELSE
  156. IF (KIMP.GE.4) WRITE(6,*) ' KREMP2 FACES NON PARALLES '
  157. LEX = IM(NF1,NF2)
  158. IF (LEX.EQ.0) THEN
  159. WRITE(6,*) ' PB FACES ',K1,' ',K2,' CAS 3'
  160. ENDIF
  161. KELT = LEX-LS1
  162. IF (KELT.GE.1 ) THEN
  163. CALL K2EMPI(K2,NF1,LS1+1,LEX,C,U2,SHC2D,SKBUF2,SKRESO)
  164. ENDIF
  165. IF (KELT.LE.-1) THEN
  166. CALL K2EMPI(K2,NF1,LEX,LS1-1,C,U2,SHC2D,SKBUF2,SKRESO)
  167. ENDIF
  168. C
  169. LEX = IM(NF2,NF1)
  170. IF (LEX.EQ.0) THEN
  171. WRITE(6,*) ' PB FACES ',K1,' ',K2,' CAS 4'
  172. ENDIF
  173. KELT = LEX-LS2
  174. IF (KELT.GE.1 ) THEN
  175. CALL K2EMPI(K2,NF2,LS2+1,LEX,C,U2,SHC2D,SKBUF2,SKRESO)
  176. ENDIF
  177. IF (KELT.LE.-1) THEN
  178. CALL K2EMPI(K2,NF2,LEX,LS2-1,C,U2,SHC2D,SKBUF2,SKRESO)
  179. ENDIF
  180. ENDIF
  181. ENDIF
  182.  
  183. RETURN
  184. END
  185.  
  186.  
  187.  

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