Télécharger pjlibr.eso

Retour à la liste

Numérotation des lignes :

  1. C PJLIBR SOURCE BP208322 17/04/18 21:15:08 9396
  2. SUBROUTINE PJLIBR(IP1,IP2,IP4,IRET )
  3. IMPLICIT INTEGER(I-N)
  4. CHARACTER*4 MOT1,MOT2,MOT3,MOT4
  5. CHARACTER*4 LDUATR(3),LDUARO(3)
  6. DIMENSION IPLACF(3),IPLACM(3)
  7. C***********************************************************************
  8. C CALCUL DES FORCES GENERALISEES DANS LE CAS D'UNE BASE TOURNANTE *
  9. C ET D'UN CHARGEMENT NON LIE A LA BASE ( OPTION LIBR DE PJBA ) *
  10. C APPELE PAR PJBA *
  11. C***********************************************************************
  12. C ARGUMENTS *
  13. C ENTREES : *
  14. C ----------- *
  15. C IP1 = CHAMPOINT ASSOCIE AU CHARGEMENT(OBJET 'CHPOINT') *
  16. C IP2 = BASE MODALE (OBJET 'BASEMODA') *
  17. C IP4 = NUMERO DE LA BASE ELEMENTAIRE AFFECTEE (ENTIER) *
  18. C SORTIES : *
  19. C ----------- *
  20. C IRET = LISTE DES CHAMPOINTS DE DECOMPOSITION DES FORCES *
  21. C GENERALISEES ( OBJET 'LISTCHPO' ) *
  22. C *
  23. C PROGAMMEUR : CHARVET QUEMIN *
  24. C***********************************************************************
  25. -INC CCOPTIO
  26. -INC SMCHPOI
  27. -INC SMLCHPO
  28. -INC SMLREEL
  29. SEGMENT ICARA
  30. CHARACTER*4 LCARA(NCARA)
  31. ENDSEGMENT
  32. SEGMENT ILIST
  33. INTEGER LIST(NLIST)
  34. ENDSEGMENT
  35. C
  36. DATA LDUATR/'FX ','FY ','FZ '/
  37. DATA LDUARO/'MX ','MY ','MZ '/
  38. C
  39. IF(IFOMOD.EQ.0) GOTO 5000
  40. DO 1 I=1,3
  41. IPLACF(I) = 0
  42. IPLACM(I) = 0
  43. 1 CONTINUE
  44. C
  45. C DESCRIPTION DES COMPOSANTES DU CHAMPOINT IP1
  46. NBMO = 0
  47. MCHPOI = IP1
  48. SEGACT MCHPOI
  49. MSOUPO = IPCHP(1)
  50. SEGACT MSOUPO
  51. SEGDES MCHPOI
  52. NDDL = NOCOMP(/2)
  53. NCARA = NDDL
  54. SEGINI ICARA
  55. MOTDDL = ICARA
  56. DO 2 I = 1,NDDL
  57. MOT1 = NOCOMP(I)
  58. LCARA(I) = MOT1
  59. DO 3 J = 1,IDIM
  60. IF( MOT1.EQ.LDUARO(J) ) THEN
  61. IPLACM(J) = I
  62. NBMO = NBMO + 1
  63. GOTO 2
  64. ENDIF
  65. IF( MOT1.EQ.LDUATR(J) ) THEN
  66. IPLACF(J) = I
  67. GOTO 2
  68. ENDIF
  69. 3 CONTINUE
  70. 2 CONTINUE
  71. IF( NBMO.NE.0. AND .IDIM.EQ.2 ) GOTO 6000
  72. C
  73. C CREATION D'UN CHAMPOINT NUL
  74. IPOE = IGEOC
  75. SEGDES MSOUPO
  76. JG = 1
  77. SEGINI MLREEL
  78. PROG(1) = 0.D0
  79. IL0 = MLREEL
  80. NLIST = NDDL
  81. SEGINI ILIST
  82. DO 4 I =1,NDDL
  83. LIST(I) = IL0
  84. 4 CONTINUE
  85. LIST0 = ILIST
  86. CALL MANUC1(IPOE,MOTDDL,LIST0,ICH0)
  87. ILIST = LIST0
  88. SEGSUP ILIST
  89. MLREEL= IL0
  90. SEGSUP MLREEL
  91. ICARA = MOTDDL
  92. SEGSUP ICARA
  93. C
  94. N1 = IDIM * IDIM
  95. SEGINI MLCHPO
  96. C
  97. C CALCUL DES CHAMPOINTS DE DECOMPOSITION
  98. DO 5 I = 1,IDIM
  99. MOT2 = LDUATR(I)
  100. IF ( NBMO.NE.0. AND .IDIM.EQ.3 ) MOT4 = LDUARO(I)
  101. C
  102. DO 6 J = 1,IDIM
  103. K = (J-1) * IDIM + I
  104. IF(IPLACF(J).EQ.0) THEN
  105. CALL COPIE2(ICH0,ICH)
  106. ELSE
  107. MOT1 = LDUATR(J)
  108. CALL EXCOPP (IP1,MOT1,NIFOUR,ICH,MOT2,NIFOUR,0 )
  109. ENDIF
  110. IF( IPLACM(J).NE.0) THEN
  111. IF ( NBMO.NE.0. AND .IDIM.EQ.3 ) MOT3 = LDUARO(J)
  112. CALL EXCOPP (IP1,MOT3,NIFOUR,ICHR,MOT4,NIFOUR,0 )
  113. CALL ADCHPO (ICHR,ICH,ICH2,1D0,-1D0)
  114. CALL DTCHPO (ICHR)
  115. CALL DTCHPO (ICH)
  116. CALL COPIE2(ICH2,ICH)
  117. CALL DTCHPO(ICH2)
  118. ENDIF
  119. CALL PROJBA( ICH,IP2,IP4,IRET1 )
  120. IF ( IRET1 .EQ. 0 ) THEN
  121. DO 7 L = 1,N1
  122. IRET2 = ICHPOI(L)
  123. IF(IRET2.NE.0) CALL DTCHPO(IRET2)
  124. 7 CONTINUE
  125. SEGSUP MLCHPO
  126. CALL DTCHPO (ICH0)
  127. RETURN
  128. ENDIF
  129. ICHPOI(K) = IRET1
  130. CALL DTCHPO(ICH)
  131. 6 CONTINUE
  132. 5 CONTINUE
  133. IRET = MLCHPO
  134. SEGDES MLCHPO
  135. CALL DTCHPO(ICH0)
  136. RETURN
  137. C
  138. 5000 CONTINUE
  139. WRITE(IOIMP,5001)
  140. 5001 FORMAT(' LE CAS AXISYMETRIQUE N EXISTE PAS ENCORE POUR L OPTION
  141. *LIBR DE PJBA ')
  142. RETURN
  143. 6000 CONTINUE
  144. WRITE(IOIMP,6001)
  145. 6001 FORMAT(' LA FORMULATION COQUE PLANE N EXISTE PAS ENCORE POUR L OPT
  146. *ION LIBR DE PJBA ')
  147. RETURN
  148. END
  149.  
  150.  
  151.  
  152.  

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