Télécharger la plaquette Cast3M


fr en

Télécharger psreco.eso

Retour à la liste

Numérotation des lignes : 

psreco

  1. C PSRECO    SOURCE    CB215821  20/11/25    13:38:03     10792          
  2.       SUBROUTINE PSRECO(IMODE,IPSMO,TYPE,ICHAR,ICHLIA,TEMPS,IRET)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,Q-Z)
  5. ************************************************************************
  6. *
  7. *                             P S R E C O
  8. *                             -----------
  9. *
  10. * FONCTION:
  11. * ---------
  12. *
  13. *     AJOUTE LA CONTRIBUTIONN DUE AUX MODES NEGLIGES.
  14. *
  15. * MODULES UTILISES:
  16. * -----------------
  17. *
  18. -INC CCHAMP
  19.  
  20. -INC PPARAM
  21. -INC CCOPTIO
  22. -INC CCREEL
  23. *-
  24. -INC SMATTAC
  25. -INC SMCHARG
  26. -INC SMCHPOI
  27. -INC SMELEME
  28. -INC SMLREEL
  29. -INC SMSOLUT
  30. *
  31. * PARAMETRES:   (E)=ENTREE   (S)=SORTIE   (+ = CONTENU DANS UN COMMUN)
  32. * -----------
  33. *
  34. *     IMODE   (E)  OBJET SOLUTION DE SOUS-TYPE MODE.
  35. *     IPSMO   (E)  OBJET SOLUTION DE SOUS-TYPE PSEUMODE.
  36. *     TYPE    (E)  DEPL OU CONT.
  37. *     ICHAR   (E)  POINTEUR SUR LE CHARGEMENT.
  38. *     ICHLIA  (E)  CHPOINT DES FORCES DE LIAISON.
  39. *     TEMPS   (E)  TEMPS DE LA RECOMBINAISON.
  40. *     IRET    (E)  POINTEUR SUR LE CHPOINT DE RECOMBINAISON.
  41. *             (S)  POINTEUR SUR LE CHPOINT DE RECOMBINAISON.
  42. *
  43.       CHARACTER*4 TYPE
  44. *
  45. * VARIABLES:
  46. * ----------
  47. *
  48.       CHARACTER*4 COMP,CC,MONTYP,DIRECT
  49.       PARAMETER (TOLER = 1.D-6)
  50. *
  51. *
  52. * AUTEUR, DATE DE CREATION:
  53. * -------------------------
  54. *
  55. *     LIONEL VIVAN       SEPTEMBRE 1988
  56. *
  57. * LANGAGE:
  58. * --------
  59. *
  60. *     ESOPE + FORTRAN77
  61. *
  62. * PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 02/91
  63. *
  64. ************************************************************************
  65. *
  66.       IF (IPSMO.EQ.0) THEN
  67.          CALL ERREUR(429)
  68.          RETURN
  69.       ENDIF
  70. *
  71.       IF (ICHAR.EQ.0 .AND. ICHLIA.EQ.0) THEN
  72.          CALL ERREUR(430)
  73.          RETURN
  74.       ENDIF
  75. *
  76.       IF (TEMPS.LT.XPETIT) THEN
  77.          CALL ERREUR(431)
  78.          RETURN
  79.       ENDIF
  80. *
  81.       MSOLUT = IPSMO
  82.       SEGACT MSOLUT
  83. *
  84.       MSOLEN = MSOLIS(10)
  85.       SEGACT MSOLEN
  86.       NPS = ISOLEN(/1)
  87. *
  88.       IF (TYPE.EQ.'DEPL') THEN
  89.          MSOLE1 = MSOLIS(5)
  90.       ELSE IF (TYPE.EQ.'CONT') THEN
  91.          MSOLE1 = MSOLIS(6)
  92.       ELSE
  93.          GOTO 9000
  94.       ENDIF
  95. *
  96.       IF (MSOLE1.EQ.0) THEN
  97. *        MANQUE LES DEPLACEMENTS OU LES CONTRAINTES
  98.          IF (TYPE.EQ.'DEPL') THEN
  99.             MOTERR(1:12) = 'DEPLACEMENTS'
  100.          ELSE
  101.             MOTERR(1:12) = 'CONTRAINTES '
  102.          ENDIF
  103.          CALL ERREUR(427)
  104.          GOTO 9000
  105.       ENDIF
  106.       SEGACT MSOLE1
  107. *
  108.       IF (ICHAR.NE.0) THEN
  109.          MCHARG = ICHAR
  110.          SEGACT MCHARG
  111.          NCH = KCHARG(/1)
  112.       ENDIF
  113. *
  114.       DO 10 IP = 1,NPS
  115.          MJONCT = ISOLEN(IP)
  116.          SEGACT MJONCT
  117.          MONTYP = MJOTYP
  118. *
  119. *        PSEUDO-MODE D'UNE STRUCTURE MULTISUPPORTEE
  120. *
  121.          IF (MONTYP.EQ.'DEPL') THEN
  122.             IF (ICHAR.EQ.0) THEN
  123.                SEGDES MJONCT
  124.                GOTO 10
  125.             ENDIF
  126.             ICHM = IPCHJO(1)
  127. *           RECHERCHE DU CHARGEMENT
  128.             DO 12 IC = 1,NCH
  129.                ICHARG = KCHARG(IC)
  130.                SEGACT ICHARG
  131.                IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(IC).NE.'STAT'
  132.      & .OR.CHALIE(IC).NE.'LIE ') THEN
  133.                   SEGDES ICHARG
  134.                   GOTO 12
  135.                ENDIF
  136.                ICHC = ICHPO1
  137.                IF (ICHC.EQ.ICHM) THEN
  138. *                 ON A TROUVE LE CHARGEMENT
  139.                   GOTO 100
  140.                ENDIF
  141.                SEGDES ICHARG
  142. 12          CONTINUE
  143. *
  144. *           IL N'Y A PAS DE CHARGEMENT POUR CE PSEUDO-MODE
  145. *
  146.             INTERR(1) = IP
  147.             CALL ERREUR(428)
  148.             SEGDES MJONCT
  149.             GOTO 10
  150. *
  151. *        PSEUDO-MODE D'UNE FORCE CONCENTREE
  152. *
  153.          ELSE IF (MONTYP.EQ.'FORC') THEN
  154.             IF (ICHAR.EQ.0) THEN
  155.                SEGDES MJONCT
  156.                GOTO 10
  157.             ENDIF
  158.             ICHM = IPCHJO(1)
  159. *           RECHERCHE DU CHARGEMENT
  160.             DO 22 IC = 1,NCH
  161.                ICHARG = KCHARG(IC)
  162.                SEGACT ICHARG
  163.                IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(IC).NE.'STAT'
  164.      & .OR.CHALIE(IC).NE.'LIE ') THEN
  165.                   SEGDES ICHARG
  166.                   GOTO 22
  167.                ENDIF
  168.                ICHC = ICHPO1
  169.                IF (ICHC.EQ.ICHM) THEN
  170. *                 ON A TROUVE LE CHARGEMENT
  171.                   GOTO 100
  172.                ENDIF
  173.                SEGDES ICHARG
  174. 22          CONTINUE
  175. *
  176. *           IL N'Y A PAS DE CHARGEMENT POUR CE PSEUDO-MODE
  177. *
  178.             INTERR(1) = IP
  179.             CALL ERREUR(428)
  180.             SEGDES MJONCT
  181.             GOTO 10
  182. *
  183. *        PSEUDO-MODE D'UNE EXCITATION SISMIQUE D'ENSEMBLE
  184. *
  185.          ELSE IF (MONTYP.EQ.'SEIS') THEN
  186.             IF (ICHAR.EQ.0) THEN
  187.                SEGDES MJONCT
  188.                GOTO 10
  189.             ENDIF
  190.             DIRECT = MJODDL
  191.             IF (DIRECT.EQ.'UX  ') THEN
  192.                IPLAC = 3
  193.             ELSE IF (DIRECT.EQ.'UY  ') THEN
  194.                IPLAC = 4
  195.             ELSE
  196.                IPLAC = 5
  197.             ENDIF
  198.             MSO1 = IMODE
  199.             SEGACT MSO1
  200.             MSOLE2 = MSO1.MSOLIS(4)
  201.             SEGDES MSO1
  202.             SEGACT MSOLE2
  203.             MMODE = MSOLE2.ISOLEN(1)
  204.             SEGDES MSOLE2
  205.             SEGACT MMODE
  206.             QPS = FMMODD(IPLAC)
  207.             QPS = -1.D0 * QPS
  208.             SEGDES MMODE
  209. *           RECHERCHE DU CHARGEMENT
  210.             DO 32 IC = 1,NCH
  211.                ICHARG = KCHARG(IC)
  212.                SEGACT ICHARG
  213.                IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(IC).NE.'STAT'
  214.      & .OR.CHALIE(IC).NE.'LIE ') THEN
  215.                   SEGDES ICHARG
  216.                   GOTO 32
  217.                ENDIF
  218.                MCHPOI = ICHPO1
  219.                SEGACT MCHPOI
  220.                MSOUPO = IPCHP(1)
  221.                SEGDES MCHPOI
  222.                SEGACT MSOUPO
  223.                MPOVAL = IPOVAL
  224.                SEGDES MSOUPO
  225.                SEGACT MPOVAL
  226.                QXYZ = VPOCHA(1,1)
  227.                SEGDES MPOVAL
  228.                EPS = ABS(QPS - QXYZ)
  229.                IF (EPS.LT.TOLER) THEN
  230. *                 ON A TROUVE LE CHARGEMENT
  231.                   GOTO 100
  232.                ENDIF
  233.                SEGDES ICHARG
  234. 32          CONTINUE
  235. *
  236. *           IL N'Y A PAS DE CHARGEMENT POUR CE PSEUDO-MODE
  237. *
  238.             INTERR(1) = IP
  239.             CALL ERREUR(428)
  240.             SEGDES MJONCT
  241.             GOTO 10
  242. *
  243. *        PSEUDO-MODE D'UNE FORCE DE CHOC
  244. *
  245.          ELSE IF (MONTYP.EQ.'CHOC') THEN
  246.             IF (ICHLIA.EQ.0) THEN
  247.                SEGDES MJONCT
  248.                GOTO 10
  249.             ENDIF
  250.             GOTO 100
  251.          ENDIF
  252. *
  253. 100      CONTINUE
  254.          ICHP = MSOLE1.ISOLEN(IP)
  255. *
  256.          IF (MONTYP.EQ.'CHOC') THEN
  257.             IPOINP = MJOPOI
  258.             COMP = MJODDL
  259.             CALL ECROBJ('POINT   ',IPOINP)
  260.             CALL ECRCHA(COMP)
  261.             CALL ECROBJ('CHPOINT ',ICHLIA)
  262.             CALL EXTRAI
  263.             CALL LIRREE(FTEMPS,1,IRETOU)
  264.             IF (IERR.NE.0) RETURN
  265.          ELSE
  266.             FTEMPS = 0.D0
  267.             MLREE1 = ICHPO2
  268.             SEGACT MLREE1
  269.             NF = MLREE1.PROG(/1)
  270.             MLREE2 = ICHPO3
  271.             SEGACT MLREE2
  272.             N1 = 1
  273.             N2 = 2
  274.             CALL INTLIN(TEMPS,ICHPO2,ICHPO3,NF,N1,N2,FT0,IRETOU)
  275.             IF (IRETOU.EQ.0) THEN
  276.                INTERR(1) = IP
  277.                CALL ERREUR(428)
  278.                GOTO 10
  279.             ENDIF
  280.             FTEMPS = FT0
  281.             SEGDES MLREE1
  282.             SEGDES MLREE2
  283.             SEGDES ICHARG
  284.          ENDIF
  285. *
  286.       IF (IIMPI.EQ.1804) THEN
  287.       PRINT*,'-- prise en compte des pseudo-modes -- FTEMPS :',FTEMPS
  288.       ENDIF
  289. *
  290.          N1 = 1
  291.          IF (TYPE.EQ.'DEPL') THEN
  292.             CALL ADCHPO(IRET,ICHP,IRET,1D0,FTEMPS)
  293.          ELSE
  294.             IPCHE1 = ICHP
  295.             IF (IP.EQ.1) IPRET = IRET
  296. *
  297.             CALL MUCHEL(IPCHE1,FTEMPS,ICHP1,N1)
  298.             CALL ADCHEL(IPRET,ICHP1,IPRET,N1)
  299.             CALL DTCHAM(ICHP1)
  300.          ENDIF
  301.          SEGDES MJONCT
  302. *
  303. 10    CONTINUE
  304. *
  305.       SEGDES MSOLE1
  306.       IF (ICHAR.NE.0) THEN
  307.          SEGDES MCHARG
  308.       ENDIF
  309. *
  310.  9000 CONTINUE
  311.       SEGDES MSOLEN
  312.       SEGDES MSOLUT
  313.  
  314.       RETURN
  315.       END
  316.  
  317.  
  318.  
  319.  
  320.  

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