Télécharger muposc.eso

Retour à la liste

Numérotation des lignes :

  1. C MUPOSC SOURCE PV 15/04/13 21:15:14 8474
  2. SUBROUTINE MUPOSC(IPOI1,IPOI2,IEPS,IRET)
  3. C=======================================================================
  4. C
  5. C ENTREE
  6. C IPOI1=CHPOINT
  7. C IPOI2=CHPOINT
  8. C IEPS =1 MULTIPLICATION -1 DIVISION
  9. C SORTIES
  10. C IRET =POINTEUR SUR CHPOINT RESULTANT
  11. C =0 SINON (UN MESSAGE D ERREUR EST ALORS IMPRIME )
  12. C
  13. C REGLE DE MULTIPLICATION : TOUT POINT AYANT DANS UN CHPOINT UNE
  14. C COMPOSANTE UNIQUE DE NOM "SCAL" VOIT TOUTES LES VALEURS DES
  15. C COMPOSANTES DE L'AUTRE CHPOINT MULTIPLIER PAR LA VALEUR SCALAIRE.
  16. C
  17. C LE CHPOINT RESULTAT NE COMPORTE QUE LES POINTS CITES CI-DESSUS.
  18. C
  19. C=======================================================================
  20. IMPLICIT INTEGER(I-N)
  21. IMPLICIT REAL*8(A-H,O-Z)
  22. -INC SMCHPOI
  23. -INC SMCOORD
  24. -INC CCOPTIO
  25. -INC SMELEME
  26. -INC TMTRAV
  27. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  28. SEGMENT ICOR(XCOOR(/1)/(IDIM+1))
  29. SEGMENT ICOM(0)
  30. SEGMENT SCOM
  31. CHARACTER*4 COM(0)
  32. ENDSEGMENT
  33. SEGMENT NOHA(0)
  34.  
  35.  
  36. CHARACTER*4 MOTCLE(3),MONATU(1)
  37. DATA MOTCLE/'INDE','DIFF','DISC'/
  38. DATA MONATU/'NATU'/
  39.  
  40.  
  41.  
  42. IRET=0
  43. MCHPO1=IPOI1
  44. MCHPO2=IPOI2
  45. MCHPOI=MCHPO1
  46. IPASS=0
  47. IA=0
  48. SEGINI ICPR ,SCOM ,NOHA
  49. C
  50. C ON FABRIQUE MTRAV A LA DIMENSION MAX POUR CELA FABRICATION DE
  51. C ICPR QUI DONNE NNNOE PUIS DE ICOM QUI SERA NNIN
  52. 1000 CONTINUE
  53. SEGACT MCHPOI
  54. NSOUP =IPCHP(/1)
  55.  
  56. DO 1 I = 1,NSOUP
  57. MSOUPO=IPCHP(I)
  58. SEGACT MSOUPO
  59. IF(I.EQ.1.AND.IPASS.EQ.0) THEN
  60. COM(**)=NOCOMP(1)
  61. NOHA(**)=NOHARM(1)
  62. ENDIF
  63.  
  64. DO 2 J=1,NOCOMP(/2)
  65. NNIN=COM(/2)
  66. DO 3 K=1,NNIN
  67. IF(NOCOMP(J).EQ.COM(K)) GO TO 2
  68. 3 CONTINUE
  69.  
  70. COM(**) =NOCOMP(J)
  71. NOHA(**)=NOHARM(J)
  72. 2 CONTINUE
  73.  
  74. MELEME=IGEOC
  75. SEGACT MELEME
  76.  
  77. DO 4 J=1,NUM(/2)
  78. IF(ICPR(NUM(1,J)).NE.0) GO TO 4
  79. IA=IA+1
  80. ICPR(NUM(1,J))=IA
  81. 4 CONTINUE
  82.  
  83. SEGDES MELEME,MSOUPO
  84. 1 CONTINUE
  85.  
  86. IF(IIMPI.NE.0) WRITE(IOIMP,100) IA
  87.  
  88. 100 FORMAT(' NOMBRE DE NOEUDS CONCERNES PAR LES 2 CHPOINTS',I5)
  89. SEGDES MCHPOI
  90. IF(IPASS.EQ.0) THEN
  91. IPASS=1
  92. MCHPOI=MCHPO2
  93. GO TO 1000
  94. ENDIF
  95. NNNOE=IA
  96. NNIN=COM(/2)
  97. SEGINI MTRAV
  98. C
  99. C ON REMPLIT INCO ET IGEO
  100. C
  101. DO 5 I=1,NNIN
  102. NHAR(I)=NOHA(I)
  103. INCO(I)=COM(I)
  104. 5 CONTINUE
  105.  
  106. SEGSUP SCOM,NOHA
  107. MCHPOI=MCHPO1
  108. IPASS=0
  109.  
  110. 1001 CONTINUE
  111. SEGACT MCHPOI
  112. NSOUP = IPCHP(/1)
  113.  
  114. DO 6 I=1,NSOUP
  115. MSOUPO=IPCHP(I)
  116. SEGACT MSOUPO
  117. MELEME=IGEOC
  118. SEGACT MELEME
  119.  
  120. DO 7 J = 1,NUM(/2)
  121. IA=ICPR(NUM(1,J))
  122. IGEO(IA)=NUM(1,J)
  123. 7 CONTINUE
  124.  
  125. SEGDES MELEME,MSOUPO
  126. 6 CONTINUE
  127.  
  128. SEGDES MCHPOI
  129. IF(IPASS.EQ.0) THEN
  130. IPASS=1
  131. MCHPOI=MCHPO2
  132. GO TO 1001
  133. ENDIF
  134. C
  135. C ON EFFECTUE LE TRAVAIL. ON ISOLE D'ABORD LA PARTIE CONCERNANT
  136. C UNIQUEMENT UNE COMPOSANTE DE NOM "SCAL".
  137. C
  138. MCHPOI=MCHPO1
  139. MCHPO3=MCHPO2
  140. IPASS=0
  141.  
  142. 1003 CONTINUE
  143. SEGACT MCHPO3
  144.  
  145. DO 10 I=1,MCHPO3.IPCHP(/1)
  146. MSOUP3=MCHPO3.IPCHP(I)
  147. SEGACT MSOUP3
  148. IF(MSOUP3.NOCOMP(/2).NE.1.OR.MSOUP3.NOCOMP(1).NE.'SCAL') THEN
  149. SEGDES MSOUP3
  150. GO TO 10
  151. ENDIF
  152. C ON FABRIQUE UNE CORRESPONDANCE ICOR(I)=J VEUT DIRE QUE LE NOEUD I EST
  153. C EN J EME POSITION DANS CE MELEME
  154. C
  155. SEGINI ICOR
  156. IPT3=MSOUP3.IGEOC
  157. SEGACT IPT3
  158. DO 11 J=1,IPT3.NUM(/2)
  159. ICOR(IPT3.NUM(1,J))=J
  160. 11 CONTINUE
  161. MPOVA3=MSOUP3.IPOVAL
  162. SEGDES MSOUP3,IPT3
  163. SEGACT MPOVA3
  164. SEGACT MCHPOI
  165. DO 12 J=1,IPCHP(/1)
  166. MSOUPO=IPCHP(J)
  167. SEGACT MSOUPO
  168. IF(IPASS.NE.0) THEN
  169. C TEST POUR NE PAS REFAIRE LA MULTIPLICATION SCAL PAR SCAL
  170. IF(NOCOMP(/2).EQ.1.AND.NOCOMP(1).EQ.'SCAL') THEN
  171. SEGDES MSOUPO
  172. GO TO 12
  173. ENDIF
  174. ENDIF
  175. SEGINI ICOM
  176. DO 13 K=1,NOCOMP(/2)
  177. DO 13 L=1,NNIN
  178. IF(NOCOMP(K).EQ.INCO(L)) ICOM(**) = L
  179. 13 CONTINUE
  180. MELEME=IGEOC
  181. MPOVAL=IPOVAL
  182. SEGACT MELEME,MPOVAL
  183. DO 14 K=1,NUM(/2)
  184. IC=ICOR(NUM(1,K))
  185. IF(IC.EQ.0) GO TO 14
  186. IB=ICPR(NUM(1,K))
  187. DO 15 L=1,NOCOMP(/2)
  188. IE=ICOM(L)
  189. IBIN(IE,IB)=1
  190. IF(IEPS.EQ.1)BB(IE,IB)=BB(IE,IB)+MPOVA3.VPOCHA(IC,1)*VPOCHA(K,L)
  191. IF(IEPS.EQ.-1)BB(IE,IB)=BB(IE,IB)+VPOCHA(K,L)/MPOVA3.VPOCHA(IC,1)
  192. 15 CONTINUE
  193. 14 CONTINUE
  194. SEGDES MELEME,MPOVAL,MSOUPO
  195. SEGSUP ICOM
  196. 12 CONTINUE
  197. SEGDES MPOVA3,MCHPOI
  198. SEGSUP ICOR
  199. 10 CONTINUE
  200. SEGDES MCHPO3
  201. IF(IPASS.EQ.0) THEN
  202. MCHPOI=MCHPO2
  203. MCHPO3=MCHPO1
  204. IPASS=1
  205. GO TO 1003
  206. ENDIF
  207. KTRAV=MTRAV
  208. CSG Emettre une erreur ne semble pas forcément utile
  209. CSG On laisse la création d'un chpoint vide par CRECHP
  210. C DO 50 I=1,NNIN
  211. C DO 50 J=1,NNNOE
  212. C IF(IBIN(I,J).NE.0) GO TO 60
  213. C 50 CONTINUE
  214. C CALL ERREUR(179)
  215. C SEGSUP MTRAV,ICPR
  216. C RETURN
  217. C 60 CONTINUE
  218. CALL CRECHP(KTRAV,IRET)
  219.  
  220.  
  221. C nature du champoint
  222. MCHPO3 = IRET
  223. SEGACT,MCHPO1
  224. SEGACT,MCHPO2
  225. SEGACT,MCHPO3*MOD
  226. CALL LIRMOT(MONATU,1,IVAL,0)
  227.  
  228. IF ( IVAL .EQ.1 ) THEN
  229. C Cas de la lecture imposée de la 'NATURE' du champ résultat
  230. CALL LIRMOT(MOTCLE,3,IVAL,1)
  231. IF ( IERR .NE. 0) RETURN
  232. MCHPO3.JATTRI(1) = IVAL-1
  233.  
  234. ELSE
  235. C Cas du calcul de la 'NATURE' du champ résultat
  236. NATRI = MCHPO1.JATTRI(1) * MCHPO2.JATTRI(1)
  237. IF ( NATRI .EQ. 0) THEN
  238. MCHPO3.JATTRI(1) = 0
  239. ELSE IF ( NATRI .EQ. 1) THEN
  240. MCHPO3.JATTRI(1) = 1
  241. ELSE IF ( NATRI .EQ. 2) THEN
  242. C la nature discrete domine
  243. MCHPO3.JATTRI(1) = 2
  244. ELSE
  245. MCHPO3.JATTRI(1) = 2
  246. ENDIF
  247. ENDIF
  248. SEGDES,MCHPO1,MCHPO2,MCHPO3
  249. IRET=MCHPO3
  250.  
  251. MTRAV=KTRAV
  252. SEGSUP MTRAV,ICPR
  253. RETURN
  254. END
  255.  
  256.  
  257.  
  258.  
  259.  
  260.  
  261.  

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