Télécharger meladd.eso

Retour à la liste

Numérotation des lignes :

  1. C MELADD SOURCE PV 16/12/14 21:15:32 9261
  2.  
  3. *----------------------------------------------------------------------*
  4. * ADDITION DE 2 MELVALS, LE SECOND ETANT AJOUTE AU PREMIER.
  5. *----------------------------------------------------------------------*
  6. * ENTREES :
  7. * IELVA1 MELVAL A COMPLETER <- ACTif et MOD en Entree/Sortie
  8. * IELVA2 MELVAL A AJOUTER <- ACTif en Entree/Sortie
  9. * TYPCHA TYPE DES CHAMPS CI-DESSUS ADDITIONNER
  10. * ILEL21 = 0 si les maillages des melvals se correspondent element
  11. * par element
  12. * = MLENTI(>0) liste d'entiers donnant la correspondance
  13. * des elements du champ2 presents dans le champ1 (addition
  14. * des valeurs commmunes)
  15. *
  16. * SORTIES :
  17. * IELVA1 MELVAL RESULTAT COMPLETE <- ACTif et MOD en Sortie
  18. * IRET = 0 si pas d'erreur
  19. * = entier non nul correspondant a l'erreur :
  20. * 104, 21, 197 par ex.
  21. *----------------------------------------------------------------------*
  22.  
  23. SUBROUTINE MELADD (IELVA1,IELVA2,TYPCHA,ILEL21,IRET)
  24.  
  25. IMPLICIT INTEGER(I-N)
  26. IMPLICIT REAL*8(A-H,O-Z)
  27.  
  28. -INC CCOPTIO
  29.  
  30. -INC SMCHAML
  31.  
  32. -INC SMCOORD
  33. -INC SMLENTI
  34. -INC SMLREEL
  35.  
  36. CHARACTER*(*) TYPCHA
  37.  
  38. IRET = 0
  39. melva1 = IELVA1
  40. melva2 = IELVA2
  41. * SEGACT,melva1*MOD <- suppose ACTif et MOD en Entree
  42. * SEGACT melva2 <- suppose ACTif en Entree
  43. mlenti = ILEL21
  44. * IF (mlenti.NE.0) SEGACT,mlenti <- suppose ACTif en Entree
  45.  
  46. * 1---------------------------1
  47. * 1. MELVAL a valeurs reelles :
  48. * 1---------------------------1
  49. IF (TYPCHA.EQ.'REAL*8') THEN
  50. nbpi1 = melva1.velche(/1)
  51. nbel1 = melva1.velche(/2)
  52. nbpi2 = melva2.velche(/1)
  53. nbel2 = melva2.velche(/2)
  54.  
  55. * "Extension" de melva1 par rapport a melva2 (MELEXT)
  56. nbpie = nbpi2
  57. IF (mlenti.NE.0) THEN
  58. nbele = mlenti.lect(/1)
  59. IF (nbel1.GT.1 .AND. nbel1.NE.nbele) THEN
  60. write(ioimp,*) 'MELADD : nbele .NE. nbel1 > 1 !'
  61. call erreur(5)
  62. ENDIF
  63. ELSE
  64. nbele = nbel2
  65. IF (nbel1.GT.1 .AND. nbel2.GT.1 .AND. nbel1.NE.nbel2) THEN
  66. write(ioimp,*) 'MELADD : nbel2 .NE. nbel1 > 1 !'
  67. call erreur(5)
  68. ENDIF
  69. ENDIF
  70. CALL MELEXT(melva1,nbpie,nbele)
  71.  
  72. * Addition des valeurs de melva2 dans melva1 pour les elements communs :
  73. nbpi1 = melva1.velche(/1)
  74. nbel1 = melva1.velche(/2)
  75. DO iel1 = 1, nbel1
  76. iel2 = iel1
  77. IF (mlenti.NE.0) iel2 = mlenti.lect(iel1)
  78. IF (iel2.GT.0) THEN
  79. jel2 = MIN(iel2,nbel2)
  80. DO igau1 = 1, nbpi1
  81. igau2 = MIN(igau1,nbpi2)
  82. melva1.velche(igau1,iel1) = melva1.velche(igau1,iel1)
  83. & + melva2.velche(igau2,jel2)
  84. ENDDO
  85. ENDIF
  86. ENDDO
  87.  
  88. * 2------------------------------------2
  89. * 2. MELVAL a valeurs de type pointeur :
  90. * 2------------------------------------2
  91. ELSE
  92. nbpi1 = melva1.ielche(/1)
  93. nbel1 = melva1.ielche(/2)
  94. nbpi2 = melva2.ielche(/1)
  95. nbel2 = melva2.ielche(/2)
  96.  
  97. * "Extension" de melva1 par rapport a melva2 (MELEXT)
  98. nbpie = nbpi2
  99. IF (mlenti.NE.0) THEN
  100. nbele = mlenti.lect(/1)
  101. IF (nbel1.GT.1 .AND. nbel1.NE.nbele) THEN
  102. write(ioimp,*) 'MELADD : nbele .NE. nbel1 > 1 !'
  103. call erreur(5)
  104. ENDIF
  105. ELSE
  106. nbele = nbel2
  107. IF (nbel1.GT.1 .AND. nbel2.GT.1 .AND. nbel1.NE.nbel2) THEN
  108. write(ioimp,*) 'MELADD : nbel2 .NE. nbel1 > 1 !'
  109. call erreur(5)
  110. ENDIF
  111. ENDIF
  112. CALL MELEXT(melva1,nbpie,nbele)
  113.  
  114. * Addition des valeurs de melva2 dans melva1 pour les elements communs :
  115. nbpi1 = melva1.ielche(/1)
  116. nbel1 = melva1.ielche(/2)
  117. IF (TYPCHA.EQ.'POINTEURLISTREEL') THEN
  118. DO iel1 = 1, nbel1
  119. iel2 = iel1
  120. IF (mlenti.NE.0) iel2 = mlenti.lect(iel1)
  121. IF (iel2.GT.0) THEN
  122. jel2 = MIN(iel2,nbel2)
  123. DO igau1 = 1, nbpi1
  124. igau2 = MIN(igau1,nbpi2)
  125. mlree1 = melva1.ielche(igau1,iel1)
  126. mlree2 = melva2.ielche(igau2,jel2)
  127. IF (mlree1.EQ.0) THEN
  128. melva1.ielche(igau1,iel1) = mlree2
  129. ELSE IF (mlree2.NE.0) THEN
  130. SEGACT,mlree1*MOD
  131. SEGACT,mlree2
  132. jg1 = mlree1.prog(/1)
  133. jg2 = mlree2.prog(/1)
  134. IF (jg2.LE.jg1) THEN
  135. DO i = 1, jg2
  136. mlree1.prog(i) = mlree1.prog(i) + mlree2.prog(i)
  137. ENDDO
  138. ELSE
  139. jg = jg2
  140. SEGADJ,mlree1
  141. DO i = 1, jg1
  142. mlree1.prog(i) = mlree1.prog(i) + mlree2.prog(i)
  143. ENDDO
  144. DO i = jg1+1, jg2
  145. mlree1.prog(i) = mlree2.prog(i)
  146. ENDDO
  147. ENDIF
  148. ** SEGDES,mlree1,mlree2
  149. ** on ne desactive pas, on se contente de remettre en lecture seule
  150. SEGACT mlree1
  151. ENDIF
  152. ENDDO
  153. ENDIF
  154. ENDDO
  155. ELSE IF (TYPCHA.EQ.'POINTEURPOINT ') THEN
  156. * Probleme en // car modif. mcoord bloque les assistants en deadlock.
  157. * Se pose aussi la question de la legalite de l'operation effectuee
  158. * ici sur les points = directions.
  159. idimp1 = IDIM + 1
  160. nbnoe = mcoord.xcoor(/1) / idimp1
  161. nbpts = nbnoe
  162. ** nbpts = nbpts + (nbpi1 * nbel1)
  163. ** SEGADJ,mcoord
  164.  
  165. DO iel1 = 1, nbel1
  166. iel2 = iel1
  167. IF (mlenti.NE.0) iel2 = mlenti.lect(iel1)
  168. IF (iel2.GT.0) THEN
  169. jel2 = MIN(iel2,nbel2)
  170. DO igau1 = 1, nbpi1
  171. igau2 = MIN(igau1,nbpi2)
  172. ip1 = melva1.ielche(igau1,iel1)
  173. ip2 = melva2.ielche(igau2,jel2)
  174. IF (ip1.EQ.0) THEN
  175. melva1.ielche(igau1,iel1) = ip2
  176. ELSE IF (ip2.NE.0) THEN
  177. C- Si les numeros des points sont differents, on va tester s'ils
  178. C- n'ont pas les memes coordonnees. Si non, alors erreur 5...
  179. IF (ip1.NE.ip2) THEN
  180. iref1 = (ip1-1) * idimp1
  181. iref2 = (ip2-1) * idimp1
  182. i_z = 0
  183. DO i = 1, idim
  184. r_z1 = MAX( ABS(xcoor(iref1+i)) ,
  185. & ABS(xcoor(iref2+i)) )
  186. r_z2 = ABS( xcoor(iref1+i) - xcoor(iref2+i) )
  187. IF (r_z2 .GT. 1.D-9*r_z1) i_z = i_z + 1
  188. ENDDO
  189. IF (i_z.GT.0) nbnoe = nbnoe + 1
  190. ** A voir par la suite : tester aussi si les 2 points/vecteurs sont
  191. ** colineaires (produit vectoriel nul). Si oui, on conserve ip1 (en
  192. ** esperant celui-ci non nul).
  193. ** ireff = nbnoe * idimp1
  194. ** DO i = 1, idimp1
  195. ** xcoor(ireff+i) = xcoor(iref1+i) + xcoor(iref2+i)
  196. ** ENDDO
  197. ** nbnoe = nbnoe + 1
  198. ** melva1.ielche(igau1,iel1) = nbnoe
  199. ENDIF
  200. ENDIF
  201. ENDDO
  202. ENDIF
  203. ENDDO
  204.  
  205. IF (nbnoe.NE.nbpts) THEN
  206. write(ioimp,*) ' Cas NON prevu sur les POINTs dans MELADD'
  207. CALL ERREUR(5)
  208. ** nbpts = nbnoe
  209. ** SEGADJ,mcoord
  210. ENDIF
  211.  
  212. ELSE IF (TYPCHA.EQ.'POINTEUREVOLUTIO') THEN
  213. i_xx = 1
  214. DO iel1 = 1, nbel1
  215. iel2 = iel1
  216. IF (mlenti.NE.0) iel2 = mlenti.lect(iel1)
  217. IF (iel2.GT.0) THEN
  218. jel2 = MIN(iel2,nbel2)
  219. DO igau1 = 1, nbpi1
  220. igau2 = MIN(igau1,nbpi2)
  221. ievol1 = melva1.ielche(igau1,iel1)
  222. ievol2 = melva2.ielche(igau2,jel2)
  223. IF (ievol1.EQ.0) THEN
  224. melva1.ielche(igau1,iel1) = ievol2
  225. ELSE IF (ievol2.NE.0) THEN
  226. CALL ADEVOL(ievol1,ievol2,ievolf,i_xx)
  227. IF (ievolf.EQ.0) IRET = 21
  228. melva1.ielche(igau1,iel1) = ievolf
  229. ENDIF
  230. ENDDO
  231. ENDIF
  232. ENDDO
  233.  
  234. ELSE
  235. DO iel1 = 1, nbel1
  236. iel2 = iel1
  237. IF (mlenti.NE.0) iel2 = mlenti.lect(iel1)
  238. IF (iel2.GT.0) THEN
  239. jel2 = MIN(iel2,nbel2)
  240. DO igau1 = 1, nbpi1
  241. igau2 = MIN(igau1,nbpi2)
  242. ip1 = melva1.ielche(igau1,iel1)
  243. ip2 = melva2.ielche(igau2,jel2)
  244. IF (ip1.EQ.0) THEN
  245. melva1.ielche(igau1,iel1) = ip2
  246. ELSE IF (ip2.NE.0) THEN
  247. melva1.ielche(igau1,iel1) = 0
  248. IRET = 197
  249. ENDIF
  250. ENDDO
  251. ENDIF
  252. ENDDO
  253.  
  254. ENDIF
  255.  
  256. ENDIF
  257.  
  258. * SEGDES,melva1,melva2 <- Segments ACTifs en Sortie
  259.  
  260. RETURN
  261. END
  262.  
  263.  
  264.  
  265.  

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