Télécharger recof1.eso

Retour à la liste

Numérotation des lignes :

  1. C RECOF1 SOURCE BP208322 14/09/15 21:16:59 8150
  2. SUBROUTINE RECOF1(itbst,itbm,ichp1,ipout)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. *
  6. ************************************************************************
  7. *
  8. * CREATION : Joel KICHENIN
  9. * MODIFS :
  10. * Benoit PRABEL, 1/08/2014 : ajout possibilite de n'avoir que itbm
  11. *
  12. ************************************************************************
  13. CHARACTER*4 mocom1,motddl
  14. -INC CCOPTIO
  15. -INC SMCHPOI
  16. -INC SMELEME
  17. -INC SMTABLE
  18. -INC SMCOORD
  19.  
  20. segment icta
  21. integer icpt(ima)
  22. character*4 iccomp(ima)
  23. endsegment
  24. segment icpr(nbpts)
  25.  
  26.  
  27. nbpts=xcoor(/1)/(idim+1)
  28. ipout = 0
  29.  
  30. c---- ACTIVATION DES TABLES si elles exitent ---------------------------
  31.  
  32. if (itbst.gt.0) then
  33. mtable = itbst
  34. segact mtable
  35. ima = mlotab - 1
  36. segini icta
  37. segini icpr
  38. endif
  39. c recup des modes si la table existe
  40. itbm2=0
  41. if (itbm.gt.0) then
  42. CALL ACCTAB(itbm,'MOT',0,0.0D0,'MODES',.TRUE.,0,
  43. & 'TABLE',0,0.0D0,' ',.TRUE.,itbm2)
  44. if (ierr.ne.0) return
  45. mtable = itbm2
  46. segact mtable
  47. endif
  48.  
  49.  
  50. c---- RECOMBINAISON ----------------------------------------------------
  51.  
  52. c recup du chpoint d'entree (de composante ALFA BETA)
  53. mchpoi = ichp1
  54. segact mchpoi
  55. nsoupo = ipchp(/1)
  56.  
  57. c - boucle sur les zones du chpoint d'entree
  58. DO 10 is = 1 ,nsoupo
  59.  
  60. msoupo = ipchp(is)
  61. segact msoupo
  62. NC = NOCOMP(/2)
  63. meleme = igeoc
  64. mpoval = ipoval
  65. segact meleme,mpoval
  66. N = vpocha(/1)
  67.  
  68. c - boucle sur les composantes
  69. DO 20 ic = 1,NC
  70.  
  71. mocom1 = nocomp(ic)
  72. if (mocom1.eq.'BETA') then
  73. if(itbst.le.0) goto 20
  74. mtable = itbst
  75. ima = mlotab - 1
  76. elseif (mocom1.eq.'ALFA') then
  77. if(itbm2.le.0) goto 20
  78. mtable = itbm2
  79. ima = mlotab - 2
  80. elseif (mocom1.eq.'LX') then
  81. write(ioimp,*) 'LX a recopier tel quel... ',
  82. & 'mais pas encore fait !'
  83. goto 20
  84. else
  85. write(ioimp,*) 'RECO : le chpoint doit avoir les composantes',
  86. & ' ALFA ou BETA !'
  87. MOTERR(1:4)=mocom1
  88. call erreur(197)
  89. return
  90. endif
  91.  
  92. c - boucle sur les noeuds du chpoint
  93. DO 90 ipn = 1,N
  94. ipts = num(1,ipn)
  95. sca1 = vpocha(ipn,ic)
  96.  
  97. c recherche du mode associe a ce noeud
  98. do 85 im =1,ima
  99. CALL ACCTAB(mtable,'ENTIER',IM,0.0D0,' ',.TRUE.,0,
  100. & 'TABLE',0,0.0D0,' ',.TRUE.,ITMOD)
  101. if (ierr.ne.0) return
  102. CALL ACCTAB(ITMOD,'MOT',0,0.0D0,'POINT_REPERE',.TRUE.,0,
  103. & 'POINT',0,0.0D0,' ',.TRUE.,IPOI)
  104. if (ierr.ne.0) return
  105. if (ipoi.ne.ipts) goto 85
  106. c on a trouve le point repere : on recupere la deformee
  107. if (mocom1.eq.'BETA') then
  108. CALL ACCTAB(ITMOD,'MOT',0,0.0D0,'DEFORMEE',.TRUE.,0,
  109. & 'CHPOINT',0,0.0D0,' ',.TRUE.,ICHIN)
  110. CALL ACCTAB(ITMOD,'MOT',0,0.0D0,'POINT_LIAISON',.TRUE.,0,
  111. & 'POINT',0,0.0D0,' ',.TRUE.,ipl1)
  112. CALL ACCTAB(ITMOD,'MOT',I0,X0,'DDL_LIAISON',.TRUE.,I6,
  113. & 'MOT',I7,X1,motddl,.TRUE.,I7)
  114. icpt(im) = ipl1
  115. iccomp(im) = motddl
  116. icpr(ipl1) = icpr(ipl1) + 1
  117. else if (mocom1.eq.'ALFA') then
  118. CALL ACCTAB(ITMOD,'MOT',0,0.0D0,'DEFORMEE_MODALE',.TRUE.,0,
  119. & 'CHPOINT',0,0.0D0,' ',.TRUE.,ICHIN)
  120. else
  121. endif
  122. if (ipout.gt.0) then
  123. ich1 = ipout
  124. call adchpo(ich1,ichin,ipout,1.d0,sca1)
  125. else
  126. call muchpo(ichin,sca1,ipout,1)
  127. endif
  128. goto 90
  129. 85 continue
  130.  
  131. 90 CONTINUE
  132.  
  133. 20 CONTINUE
  134.  
  135. segdes msoupo,meleme,mpoval
  136. 10 CONTINUE
  137. segdes mchpoi
  138.  
  139.  
  140. if (itbst.le.0) goto 999
  141. C---- CORRECTION DU CHPOINT AUX POINTS DE LIAISON ----------------------
  142.  
  143. ima = icpt(/1)
  144. mchpoi = ipout
  145. segact mchpoi
  146. nsoupo = ipchp(/1)
  147.  
  148. DO is = 1 ,nsoupo
  149. msoupo = ipchp(is)
  150. segact msoupo
  151. NC = NOCOMP(/2)
  152. meleme = igeoc
  153. mpoval = ipoval
  154. segact meleme,mpoval*mod
  155. N = vpocha(/1)
  156.  
  157. DO ic = 1,NC
  158. mocom1 = nocomp(ic)
  159.  
  160. DO 180 ipn = 1 , N
  161. ipts = num(1,ipn)
  162. kpt = 0
  163. if (icpr(ipts).eq.0) goto 180
  164. c on a repere un point de liaison
  165. do 170 im = 1,ima
  166. if (icpt(im).ne.ipts) goto 170
  167. if (iccomp(im).ne.mocom1) goto 170
  168. kpt = kpt + 1
  169. 170 continue
  170.  
  171. if (kpt.ne.0) vpocha(ipn,ic) = vpocha(ipn,ic)/kpt
  172.  
  173. 180 CONTINUE
  174.  
  175. ENDDO
  176.  
  177. ENDDO
  178. segdes mchpoi
  179. segsup icta,icpr
  180.  
  181. C---- FIN DU PROGRAMME -------------------------------------------------
  182. 999 CONTINUE
  183.  
  184. RETURN
  185. END
  186.  
  187.  
  188.  
  189.  

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