Télécharger redfor.eso

Retour à la liste

Numérotation des lignes :

  1. C REDFOR SOURCE PV 20/03/30 21:23:38 10567
  2. * élimination des ddls supprimés dans le second membre réduit
  3. subroutine redfor(mchpoi,ri4,mchpo1)
  4. * inspiré de transr et mschp1 (MASQ)
  5. * mchpoi : entree = second membre réduit avec ddls supprimés
  6. * ri4 : entree = matrice de relation
  7. * mchpo1 : sortie = second membre réduit sans ddls supprimés
  8. IMPLICIT INTEGER(I-N)
  9. IMPLICIT REAL*8 (A-H,O-Z)
  10. -INC SMCHPOI
  11. -INC SMRIGID
  12.  
  13. -INC PPARAM
  14. -INC CCOPTIO
  15. -INC CCHAMP
  16. -INC SMCOORD
  17. -INC SMELEME
  18. -INC TMTRAV
  19. *
  20. SEGMENT/MTRA/(NOPOIN(nbpts))
  21. SEGMENT MTR1
  22. CHARACTER*4 IPCOM(0)
  23. ENDSEGMENT
  24. SEGMENT/MTR4/(IPHAR(0))
  25. CHARACTER*4 nomp,nomd
  26. *
  27. SEGINI MTRA,MTR1,MTR4
  28. *
  29. * Initialisation de MTRAV, MTRA, MTR1, MTR4 (repris de mschp1.eso)
  30. *
  31. SEGACT MCHPOI
  32. IK=0
  33. NSOUPO=IPCHP(/1)
  34. DO 20 IA=1,NSOUPO
  35. MSOUPO=IPCHP(IA)
  36. SEGACT MSOUPO
  37. MELEME=IGEOC
  38. SEGACT MELEME
  39. NBELEM=NUM(/2)
  40. DO 30 IB=1,NBELEM
  41. K=NUM(1,IB)
  42. IF(NOPOIN(K).NE.0) GO TO 30
  43. IK=IK+1
  44. NOPOIN(K)=IK
  45. 30 CONTINUE
  46. SEGDES MELEME
  47. NCBBB=NOCOMP(/2)
  48. DO 40 IB=1,NCBBB
  49. NC=IPCOM(/2)
  50. DO 50 IC=1,NC
  51. IF(IPCOM(IC).NE.NOCOMP(IB)) GO TO 50
  52. IF(IPHAR(IC).EQ.NOHARM(IB)) GO TO 40
  53. 50 CONTINUE
  54. IPCOM(**)=NOCOMP(IB)
  55. IPHAR(**)=NOHARM(IB)
  56. 40 CONTINUE
  57. SEGDES MSOUPO
  58. 20 CONTINUE
  59. C
  60. NNIN=IPCOM(/2)
  61. NNNOE=IK
  62. SEGINI MTRAV
  63. DO 70 IA=1,NNIN
  64. INCO(IA)=IPCOM(IA)
  65. NHAR(IA)=IPHAR(IA)
  66. 70 CONTINUE
  67. C
  68. C CREATION DE BB,IBIN,IGEO
  69. C
  70. NSOUPO=IPCHP(/1)
  71. DO 80 IA=1,NSOUPO
  72. MSOUPO=IPCHP(IA)
  73. SEGACT MSOUPO
  74. MELEME=IGEOC
  75. MPOVAL=IPOVAL
  76. SEGACT MELEME,MPOVAL
  77. NBELEM=NUM(/2)
  78. NC=VPOCHA(/2)
  79. NC1=NOCOMP(/2)
  80. C
  81. DO 90 IB=1,NC1
  82. DO 100 IC=1,NNIN
  83. IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 100
  84. IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 110
  85. 100 CONTINUE
  86. * Pas de composante trouvée, ce n'est pas normal
  87. goto 9999
  88. 110 CONTINUE
  89. DO 120 ID=1,NBELEM
  90. KI=NOPOIN(NUM(1,ID))
  91. IGEO(KI)=NUM(1,ID)
  92. IBIN(IC,KI)=1
  93. BB(IC,KI)=VPOCHA(ID,IB)
  94. 120 CONTINUE
  95. 90 CONTINUE
  96. SEGDES MELEME,MPOVAL
  97. SEGDES MSOUPO
  98. 80 CONTINUE
  99. SEGDES MCHPOI
  100. * on balaye les raideurs de dependances, on supprime les ddl dependants
  101. * dans le MTRAV
  102. segact ri4
  103. do 1100 irig=1,ri4.irigel(/2)
  104. if (ri4.irigel(8,irig).ne.0) then
  105. descr=ri4.irigel(3,irig)
  106. meleme=ri4.irigel(1,irig)
  107. Xmatri=ri4.irigel(4,irig)
  108. segact descr,meleme,xmatri
  109. do 1110 iligrp=1,lisinc(/2)
  110. if (lisinc(iligrp).eq.'LX ') goto 1120
  111. 1110 continue
  112. goto 1100
  113. 1120 continue
  114. * Le multiplicateur de lagrange n'est pas en première position
  115. * dans le descripteur de la matrice, ce n'est pas prévu
  116. if (iligrp.ne.1) goto 9999
  117. nbelem=num(/2)
  118. * on supprime le multiplicateur de lagrange et le ddl dépendant
  119. do idep=1,2
  120. nomp=lisinc(idep)
  121. * on trouve le nom dual correspondant (si non trouvé dual=primal)
  122. nomd=nomp
  123. do ipri=1,lnomdd
  124. if (nomp.eq.nomdd(ipri)) nomd=nomdu(ipri)
  125. enddo
  126. iharm=ri4.irigel(5,irig)
  127. inin=0
  128. do ii=1,nhar(/1)
  129. if (inco(ii).eq.nomd.and.nhar(ii).eq.iharm) inin=ii
  130. enddo
  131. if (inin.ne.0) then
  132. do 1130 i=1,nbelem
  133. * write(ioimp,*) 'ddl a eliminer ',iharm,nomd,' ',
  134. * $ num(noelep(idep),i)
  135. ik=nopoin(num(noelep(idep),i))
  136. if (ik.ne.0) ibin(inin,ik)=0
  137. 1130 continue
  138. endif
  139. enddo
  140. segdes descr,meleme,xmatri
  141. endif
  142. 1100 continue
  143. segdes ri4
  144. segsup MTRA,MTR1,MTR4
  145. *
  146. * On reconstruit le chpoint nettoyé et on lui donne les mêmes
  147. * caractéristiques que l'original
  148. *
  149. CALL CRECHP(mtrav,mchpo1)
  150. segsup mtrav
  151. segact mchpo1*mod
  152. segact mchpoi
  153. mchpo1.mochde='créé par redfor'
  154. mchpo1.ifopoi=ifopoi
  155. do i=1,min(mchpo1.jattri(/1),jattri(/1))
  156. mchpo1.jattri(i)=jattri(i)
  157. enddo
  158. segdes mchpoi
  159. segdes mchpo1
  160. return
  161.  
  162. 9999 continue
  163. MOTERR(1:8)='REDFOR '
  164. CALL ERREUR(1039)
  165. RETURN
  166. end
  167.  
  168.  
  169.  
  170.  
  171.  
  172.  
  173.  
  174.  
  175.  
  176.  
  177.  

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