Télécharger corrsp.eso

Retour à la liste

Numérotation des lignes :

  1. C CORRSP SOURCE BP208322 15/06/22 21:16:48 8543
  2. SUBROUTINE CORRSP(ipr,IPVEC,IPMX,IPLMOX,IPLMOY)
  3. C
  4. C**********************************************************************
  5. C
  6. C CE SP APPELE PAR ITINV, SIMUL1 ... PREPARE L OBJET 'LISTMOTS'
  7. C NECESSAIRE A L OPERATEUR XTY : COUPLE DES NOMS D INCONNUES A
  8. c ASSOCIER
  9. C
  10. C IPR : pointeur sur l'objet RIGIDITE qui définit la dualité
  11. C IPVEC : OBJET DE TYPE CHPOINT
  12. C IPMX : OBJET DE TYPE CHPOINT
  13. C IPLMOX : POINTEUR SUR OBJET LISTMOTS UX,UY....
  14. C IPLMOY : POINTEUR SUR OBJET LISTMOTS FX,FY....
  15. C
  16. C AUTEUR : D.BROCHARD
  17. C DATE : 11/01/88
  18. C
  19. C BP , novembre 2010 : on supprime l hypothese selon laquelle :
  20. c " la matrice possede des correspondances sur les inconnues
  21. c (c'est a dire que la ieme ligne est la duale de la ieme colonne) "
  22. C => On utilise NOMDD et NOMDU de CCHAMP pour créer l'association
  23. C "naturelle" entre les inconnues primales et duales (permet dutiliser
  24. C de matrices creuses commes celles crees par imped par ex.)
  25. C
  26. C*********************************************************************
  27. C
  28. C
  29. IMPLICIT INTEGER(I-N)
  30. IMPLICIT REAL*8(A-H,O-Z)
  31. CHARACTER*4 NOCO
  32. C
  33. -INC CCOPTIO
  34. -INC CCHAMP
  35. -INC SMLMOTS
  36. -INC SMCHPOI
  37. -INC SMRIGID
  38. C
  39. C
  40. pointeur lmopri.mlmots, lmodua.mlmots
  41.  
  42. iplmox=0
  43. iplmoy=0
  44. C
  45. C==== CREATION DE lmopri lmodua QUI DEFINIT LA REGLE D'ASSOCIATION ====
  46. C
  47. C CREATION BASEE SUR NOMDD et NOMDU de CCHAMP rempli dans bdata.eso
  48. C
  49. jgn=4
  50. jgm=LNOMDD
  51. segini,lmopri
  52. segini,lmodua
  53. do i=1,jgm
  54. lmopri.mots(i)=NOMDD(i)
  55. lmodua.mots(i)=NOMDU(i)
  56. enddo
  57. c C
  58. c C CREATION BASEE SUR LA MATRICE FOURNIE (ancienne syntaxe)
  59. c C
  60. mrigid=ipr
  61. segact,mrigid
  62. nbriel=irigel(/2)
  63. if (irigel(/1).lt.3) then
  64. write(*,*) 'CORRSP: Information insuffisante dans la RIGIDITE'
  65. segdes,mrigid
  66. return
  67. endif
  68. itaill=0
  69. do 1 i=1,nbriel
  70. descr=irigel(3,i)
  71. segact,descr
  72. nbcpri=lisinc(/2)
  73. nbcdua=lisdua(/2)
  74. if(nbcpri.ne.nbcdua) then
  75. * write(*,*) 'CORRSP: Zone',i,' de la RIGIDITE contient des',
  76. * & ' matrices non carrées !!!'
  77. segdes,descr
  78. goto 1
  79. endif
  80. do 2 ic=1,nbcpri
  81. if (lisinc(ic).eq.lisdua(ic)) goto 2
  82. do 6 ij=1,jgm
  83. if (lmopri.mots(ij).ne.lisinc(ic)) goto 6
  84. if (lmodua.mots(ij).eq.lisdua(ic)) goto 2
  85. moterr(1:4) = lmopri.mots(ij)
  86. moterr(5:8) = lmodua.mots(ij)
  87. moterr(9:12)= lisdua(ic)
  88. call erreur(1026)
  89. 6 continue
  90. if (jgm.eq.0) then
  91. jgm=1
  92. segadj,lmopri
  93. segadj,lmodua
  94. lmopri.mots(1)=lisinc(ic)
  95. lmodua.mots(1)=lisdua(ic)
  96. else
  97. do 3 ica=1,jgm
  98. if(lmopri.mots(ica).eq.lisinc(ic)) goto 2
  99. 3 continue
  100. jgm=jgm+1
  101. segadj,lmopri
  102. segadj,lmodua
  103. lmopri.mots(jgm)=lisinc(ic)
  104. lmodua.mots(jgm)=lisdua(ic)
  105. endif
  106. 2 continue
  107. segdes,descr
  108. 1 continue
  109. segdes,mrigid
  110. c
  111. itaill=jgm
  112.  
  113. if (iimpi.eq.321) then
  114. do 4 i=1,itaill
  115. write(*,*) lmopri.mots(i),' <=> ',lmodua.mots(i)
  116. 4 continue
  117. endif
  118. C
  119. C
  120. C==== CREATION et REMPLISSAGE DE MLMOTS MLMOT2 (= RESULTATS) ====
  121. C
  122. JGN=4
  123. JGM=0
  124. SEGINI MLMOTS
  125. SEGINI MLMOT2
  126. C
  127. C ON UTILISE LE CHPOINT PRIMAL
  128. INU=0
  129. MCHPO1=IPVEC
  130. SEGACT MCHPO1
  131. NSOUP1=MCHPO1.IPCHP(/1)
  132. C
  133. DO 10 ISOUP1 = 1,NSOUP1
  134. MSOUP1 = MCHPO1.IPCHP(ISOUP1)
  135. SEGACT MSOUP1
  136. NC1 = MSOUP1.NOCOMP(/2)
  137. DO 20 NCI = 1,NC1
  138. C
  139. IF(IIMPI.EQ.321) WRITE(IOIMP,*) NCI,MSOUP1.NOCOMP(NCI)
  140. C
  141. IF(INU.NE.0) GOTO 30
  142. NOCO = MSOUP1.NOCOMP(1)
  143. CALL PLACE(lmopri.mots(1),itaill,IPLA,NOCO)
  144. if(ipla.eq.0) goto 20
  145. JGM=JGM+1
  146. SEGADJ MLMOTS
  147. SEGADJ MLMOT2
  148. MOTS(JGM) = NOCO
  149. MLMOT2.MOTS(JGM) = lmodua.mots(IPLA)
  150. INU = INU+1
  151. GOTO 20
  152. C
  153. 30 CONTINUE
  154. NOCO = MSOUP1.NOCOMP(NCI)
  155. DO 40 I =1,INU
  156. IF(NOCO.EQ.MOTS(I)) GOTO 20
  157. 40 CONTINUE
  158. CALL PLACE(lmopri.mots(1),itaill,IPLA,NOCO)
  159. if (ipla.eq.0) goto 20
  160. INU =INU+1
  161. JGM=JGM+1
  162. SEGADJ MLMOTS
  163. SEGADJ MLMOT2
  164. MOTS(JGM) = NOCO
  165. MLMOT2.MOTS(JGM)= lmodua.mots(IPLA)
  166. 20 CONTINUE
  167. SEGDES MSOUP1
  168. 10 CONTINUE
  169. SEGDES MCHPO1
  170. C
  171. IPLMOX=MLMOTS
  172. IPLMOY=MLMOT2
  173. C
  174. C
  175. C==== VERIFICATION :
  176. C LES VARIABLES SONT ELLES BIEN DANS LE CHPOINT DUAL
  177. c
  178. c rem : il s agit seulement d un message informatif
  179. c pas d une erreur car on peut avoir u={UX RX LX}
  180. c et M*u={FX } seulement !
  181. c ca ne derange pas xty1 a priori...
  182. c IF(IIMPI.lt.5) GOTO 999
  183. c
  184. c on peut faire mieux en enlevant les couples "veufs"
  185.  
  186. C==== CREATION et REMPLISSAGE DE MLMOT1 ====
  187. JGM=0
  188. SEGINI MLMOT1
  189. IMU=0
  190. MCHPOI=IPMX
  191. SEGACT MCHPOI
  192. NSOUPO=IPCHP(/1)
  193. DO 100 ISOUPO=1,NSOUPO
  194. C
  195. MSOUPO=IPCHP(ISOUPO)
  196. SEGACT MSOUPO
  197. NC1 = NOCOMP(/2)
  198. DO 120 NCI = 1,NC1
  199. C
  200. IF(IIMPI.EQ.321) WRITE(IOIMP,*) NCI,NOCOMP(NCI)
  201. C
  202. IF (IMU.NE.0) GOTO 130
  203. NOCO = NOCOMP(1)
  204. JGM=JGM+1
  205. SEGADJ MLMOT1
  206. MLMOT1.MOTS(JGM)= NOCO
  207. IMU = IMU+1
  208. GOTO 120
  209. C
  210. 130 CONTINUE
  211. NOCO = NOCOMP(NCI)
  212. DO 140 I =1,IMU
  213. IF (NOCO.EQ.MLMOT1.MOTS(I)) GOTO 120
  214. 140 CONTINUE
  215. IMU =IMU+1
  216. JGM=JGM+1
  217. SEGADJ MLMOT1
  218. MLMOT1.MOTS(JGM) = NOCO
  219. 120 CONTINUE
  220. SEGDES MSOUPO
  221. 100 CONTINUE
  222. SEGDES MCHPOI
  223. C
  224. C==== COMPARAISON DE MLMOT1 et MLMOT2 ====
  225. c
  226. JGM1 = MLMOT1.MOTS(/2)
  227. JGM2 = MLMOT2.MOTS(/2)
  228. JGM=0
  229. DO 200 I2=1,JGM2
  230. DO 210 I1=1,JGM1
  231. IF (MLMOT2.MOTS(I2).EQ.MLMOT1.MOTS(I1)) GOTO 199
  232. 210 CONTINUE
  233. c on n a pas retrouvé cette composante
  234. IF(IIMPI.GE.5)
  235. & WRITE(*,1000) (MLMOTS.MOTS(I2)),(MLMOT2.MOTS(I2))
  236. 1000 FORMAT(/4X,'LA COMPOSANTE ',A4,' DUALE DE ',A4,
  237. & ' N EST PAS CONTENUE DANS LE SECOND CHPOINT')
  238. goto 200
  239. 199 CONTINUE
  240. c on a retrouvé cette composante duale
  241. JGM=JGM+1
  242. MLMOTS.MOTS(JGM)=MLMOTS.MOTS(I2)
  243. MLMOT2.MOTS(JGM)=MLMOT2.MOTS(I2)
  244. 200 CONTINUE
  245. if(JGM.ne.JGM2) segadj,MLMOTS,MLMOT2
  246. SEGSUP,MLMOT1
  247. C
  248. C==== MENAGE, MESSAGES et RETOUR ====
  249. c
  250. 999 CONTINUE
  251. SEGDES MLMOTS,MLMOT2
  252. segsup lmopri,lmodua
  253. C
  254. IF (IIMPI.eq.321) then
  255. WRITE(IOIMP,5000)
  256. 5000 FORMAT(/10X,'SBR CORRSP',//)
  257. CALL ECLMOT(IPLMOX)
  258. CALL ECLMOT(IPLMOY)
  259. CALL ECCHPO(IPVEC,0)
  260. CALL ECCHPO(IPMX,0)
  261. endif
  262. C
  263. RETURN
  264. END
  265.  
  266.  
  267.  
  268.  
  269.  
  270.  
  271.  
  272.  
  273.  
  274.  
  275.  
  276.  
  277.  
  278.  
  279.  

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