C PSRECO SOURCE CB215821 20/11/25 13:38:03 10792 SUBROUTINE PSRECO(IMODE,IPSMO,TYPE,ICHAR,ICHLIA,TEMPS,IRET) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,Q-Z) ************************************************************************ * * P S R E C O * ----------- * * FONCTION: * --------- * * AJOUTE LA CONTRIBUTIONN DUE AUX MODES NEGLIGES. * * MODULES UTILISES: * ----------------- * -INC CCHAMP -INC PPARAM -INC CCOPTIO -INC CCREEL *- -INC SMATTAC -INC SMCHARG -INC SMCHPOI -INC SMELEME -INC SMLREEL -INC SMSOLUT * * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN) * ----------- * * IMODE (E) OBJET SOLUTION DE SOUS-TYPE MODE. * IPSMO (E) OBJET SOLUTION DE SOUS-TYPE PSEUMODE. * TYPE (E) DEPL OU CONT. * ICHAR (E) POINTEUR SUR LE CHARGEMENT. * ICHLIA (E) CHPOINT DES FORCES DE LIAISON. * TEMPS (E) TEMPS DE LA RECOMBINAISON. * IRET (E) POINTEUR SUR LE CHPOINT DE RECOMBINAISON. * (S) POINTEUR SUR LE CHPOINT DE RECOMBINAISON. * CHARACTER*4 TYPE * * VARIABLES: * ---------- * CHARACTER*4 COMP,CC,MONTYP,DIRECT PARAMETER (TOLER = 1.D-6) * * * AUTEUR, DATE DE CREATION: * ------------------------- * * LIONEL VIVAN SEPTEMBRE 1988 * * LANGAGE: * -------- * * ESOPE + FORTRAN77 * * PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 02/91 * ************************************************************************ * IF (IPSMO.EQ.0) THEN CALL ERREUR(429) RETURN ENDIF * IF (ICHAR.EQ.0 .AND. ICHLIA.EQ.0) THEN CALL ERREUR(430) RETURN ENDIF * IF (TEMPS.LT.XPETIT) THEN CALL ERREUR(431) RETURN ENDIF * MSOLUT = IPSMO SEGACT MSOLUT * MSOLEN = MSOLIS(10) SEGACT MSOLEN NPS = ISOLEN(/1) * IF (TYPE.EQ.'DEPL') THEN MSOLE1 = MSOLIS(5) ELSE IF (TYPE.EQ.'CONT') THEN MSOLE1 = MSOLIS(6) ELSE GOTO 9000 ENDIF * IF (MSOLE1.EQ.0) THEN * MANQUE LES DEPLACEMENTS OU LES CONTRAINTES IF (TYPE.EQ.'DEPL') THEN MOTERR(1:12) = 'DEPLACEMENTS' ELSE MOTERR(1:12) = 'CONTRAINTES ' ENDIF CALL ERREUR(427) GOTO 9000 ENDIF SEGACT MSOLE1 * IF (ICHAR.NE.0) THEN MCHARG = ICHAR SEGACT MCHARG NCH = KCHARG(/1) ENDIF * DO 10 IP = 1,NPS MJONCT = ISOLEN(IP) SEGACT MJONCT MONTYP = MJOTYP * * PSEUDO-MODE D'UNE STRUCTURE MULTISUPPORTEE * IF (MONTYP.EQ.'DEPL') THEN IF (ICHAR.EQ.0) THEN SEGDES MJONCT GOTO 10 ENDIF ICHM = IPCHJO(1) * RECHERCHE DU CHARGEMENT DO 12 IC = 1,NCH ICHARG = KCHARG(IC) SEGACT ICHARG IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(IC).NE.'STAT' & .OR.CHALIE(IC).NE.'LIE ') THEN SEGDES ICHARG GOTO 12 ENDIF ICHC = ICHPO1 IF (ICHC.EQ.ICHM) THEN * ON A TROUVE LE CHARGEMENT GOTO 100 ENDIF SEGDES ICHARG 12 CONTINUE * * IL N'Y A PAS DE CHARGEMENT POUR CE PSEUDO-MODE * INTERR(1) = IP CALL ERREUR(428) SEGDES MJONCT GOTO 10 * * PSEUDO-MODE D'UNE FORCE CONCENTREE * ELSE IF (MONTYP.EQ.'FORC') THEN IF (ICHAR.EQ.0) THEN SEGDES MJONCT GOTO 10 ENDIF ICHM = IPCHJO(1) * RECHERCHE DU CHARGEMENT DO 22 IC = 1,NCH ICHARG = KCHARG(IC) SEGACT ICHARG IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(IC).NE.'STAT' & .OR.CHALIE(IC).NE.'LIE ') THEN SEGDES ICHARG GOTO 22 ENDIF ICHC = ICHPO1 IF (ICHC.EQ.ICHM) THEN * ON A TROUVE LE CHARGEMENT GOTO 100 ENDIF SEGDES ICHARG 22 CONTINUE * * IL N'Y A PAS DE CHARGEMENT POUR CE PSEUDO-MODE * INTERR(1) = IP CALL ERREUR(428) SEGDES MJONCT GOTO 10 * * PSEUDO-MODE D'UNE EXCITATION SISMIQUE D'ENSEMBLE * ELSE IF (MONTYP.EQ.'SEIS') THEN IF (ICHAR.EQ.0) THEN SEGDES MJONCT GOTO 10 ENDIF DIRECT = MJODDL IF (DIRECT.EQ.'UX ') THEN IPLAC = 3 ELSE IF (DIRECT.EQ.'UY ') THEN IPLAC = 4 ELSE IPLAC = 5 ENDIF MSO1 = IMODE SEGACT MSO1 MSOLE2 = MSO1.MSOLIS(4) SEGDES MSO1 SEGACT MSOLE2 MMODE = MSOLE2.ISOLEN(1) SEGDES MSOLE2 SEGACT MMODE QPS = FMMODD(IPLAC) QPS = -1.D0 * QPS SEGDES MMODE * RECHERCHE DU CHARGEMENT DO 32 IC = 1,NCH ICHARG = KCHARG(IC) SEGACT ICHARG IF(CHATYP.NE.'CHPOINT '.OR.CHAMOB(IC).NE.'STAT' & .OR.CHALIE(IC).NE.'LIE ') THEN SEGDES ICHARG GOTO 32 ENDIF MCHPOI = ICHPO1 SEGACT MCHPOI MSOUPO = IPCHP(1) SEGDES MCHPOI SEGACT MSOUPO MPOVAL = IPOVAL SEGDES MSOUPO SEGACT MPOVAL QXYZ = VPOCHA(1,1) SEGDES MPOVAL EPS = ABS(QPS - QXYZ) IF (EPS.LT.TOLER) THEN * ON A TROUVE LE CHARGEMENT GOTO 100 ENDIF SEGDES ICHARG 32 CONTINUE * * IL N'Y A PAS DE CHARGEMENT POUR CE PSEUDO-MODE * INTERR(1) = IP CALL ERREUR(428) SEGDES MJONCT GOTO 10 * * PSEUDO-MODE D'UNE FORCE DE CHOC * ELSE IF (MONTYP.EQ.'CHOC') THEN IF (ICHLIA.EQ.0) THEN SEGDES MJONCT GOTO 10 ENDIF GOTO 100 ENDIF * 100 CONTINUE ICHP = MSOLE1.ISOLEN(IP) * IF (MONTYP.EQ.'CHOC') THEN IPOINP = MJOPOI COMP = MJODDL CALL ECROBJ('POINT ',IPOINP) CALL ECRCHA(COMP) CALL ECROBJ('CHPOINT ',ICHLIA) CALL EXTRAI CALL LIRREE(FTEMPS,1,IRETOU) IF (IERR.NE.0) RETURN ELSE FTEMPS = 0.D0 MLREE1 = ICHPO2 SEGACT MLREE1 NF = MLREE1.PROG(/1) MLREE2 = ICHPO3 SEGACT MLREE2 N1 = 1 N2 = 2 CALL INTLIN(TEMPS,ICHPO2,ICHPO3,NF,N1,N2,FT0,IRETOU) IF (IRETOU.EQ.0) THEN INTERR(1) = IP CALL ERREUR(428) GOTO 10 ENDIF FTEMPS = FT0 SEGDES MLREE1 SEGDES MLREE2 SEGDES ICHARG ENDIF * IF (IIMPI.EQ.1804) THEN PRINT*,'-- prise en compte des pseudo-modes -- FTEMPS :',FTEMPS ENDIF * N1 = 1 IF (TYPE.EQ.'DEPL') THEN CALL ADCHPO(IRET,ICHP,IRET,1D0,FTEMPS) ELSE IPCHE1 = ICHP IF (IP.EQ.1) IPRET = IRET * CALL MUCHEL(IPCHE1,FTEMPS,ICHP1,N1) CALL ADCHEL(IPRET,ICHP1,IPRET,N1) CALL DTCHAM(ICHP1) ENDIF SEGDES MJONCT * 10 CONTINUE * SEGDES MSOLE1 IF (ICHAR.NE.0) THEN SEGDES MCHARG ENDIF * 9000 CONTINUE SEGDES MSOLEN SEGDES MSOLUT RETURN END