C PSEVO1 SOURCE BP208322 22/09/09 21:15:05 11448 SUBROUTINE PSEVO1(IMODE,IPSMO,IBOO,IPX,ILEX,ICHAR,ICONT) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) ************************************************************************ * * P S E V O 1 * ----------- * * FONCTION: * --------- * * AJOUTE LA CONTRIBUTION DES MODES NEGLIGES * POUR LES DEPLACEMENTS SI ICONT=0 * POUR LES CONTRAINTES SI ICONT=1 * * MODULES UTILISES: * ----------------- * -INC PPARAM -INC CCOPTIO -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. * IBOO (E) POINTEUR SUR LE SEGMENT NUMOO. * (S) POINTEUR SUR LE SEGMENT NUMOO. * IPX (E) POINTEUR SUR LE LISTREEL. * ILEX (E) CONTIENT LES FORCES DE LIAISON AUX TEMPS DEMANDES. * ICHAR (E) POINTEUR SUR LE CHARGEMENT. * SEGMENT NUMOO INTEGER NUMO(N),KLIST(N) CHARACTER*(LOCHPO) NUDDL(N) ENDSEGMENT * * VARIABLES: * ---------- * CHARACTER*4 COMP,COMP2,MONTYP,DIRECT PARAMETER (TOLER = 1.D-6) * * * AUTEUR, DATE DE CREATION: * ------------------------- * * LIONEL VIVAN SEPTEMBRE 1988 * * LANGAGE: * -------- * * ESOPE + FORTRAN77 * ************************************************************************ * IF (ICHAR.EQ.0 .AND. ILEX.EQ.0) THEN CALL ERREUR(430) RETURN ENDIF * NUMOO = IBOO SEGACT NUMOO NP = NUMO(/1) DO 2 I = 1,NP MLREE3 = KLIST(I) SEGACT MLREE3 2 CONTINUE * MLREEL= IPX SEGACT MLREEL LDIM = PROG(/1) * IF (ICHAR.NE.0) THEN MCHARG = ICHAR SEGACT MCHARG NCH = KCHARG(/1) ENDIF * MSOLUT = IPSMO SEGACT MSOLUT * MSOLEN = MSOLIS(10) SEGACT MSOLEN NPS = ISOLEN(/1) * IF (ICONT.EQ.0) MSOLE1 = MSOLIS(5) IF (ICONT.EQ.1) MSOLE1 = MSOLIS(6) SEGACT MSOLE1 * IF (ILEX.NE.0) THEN MSOLE2 = ILEX SEGACT MSOLE2 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 * * MANQUE LE CHARGEMENT POUR LE 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 TYPE DE 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 = -1.D0 * FMMODD(IPLAC) 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 CORRESPONDANT AU 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 (ILEX.EQ.0) THEN SEGDES MJONCT GOTO 10 ENDIF GOTO 100 ENDIF * 100 CONTINUE IF (ICONT.EQ.0) THEN ICHP = MSOLE1.ISOLEN(IP) ELSE ICCC = MSOLE1.ISOLEN(IP) CALL PELPO(ICCC,ICHP,IRETOU) IF (IRETOU.EQ.0) THEN INTERR(1) = IP CALL ERREUR(428) SEGDES MJONCT GOTO 10 ENDIF ENDIF * IF (ICHAR.NE.0) THEN MLREE1 = ICHPO2 SEGACT MLREE1 NF = MLREE1.PROG(/1) MLREE2 = ICHPO3 SEGACT MLREE2 ENDIF * N1 = 1 N2 = 2 DO 110 IT = 1,LDIM TEM1 = PROG(IT) IF (MONTYP.EQ.'CHOC') THEN FTEM1 = 0.D0 IPOINP = MJOPOI COMP = MJODDL * RECHERCHE DANS LE CHPOINT DES FORCES DE LIAISON ICHLIA = MSOLE2.ISOLEN(IT) CALL EXTRA9(ICHLIA,IPOINP,COMP,0,.FALSE.,FTEM1,IRET) IF (IRET.NE.1) THEN INTERR(1) = IP CALL ERREUR(428) SEGDES MJONCT GOTO 10 ENDIF ELSE CALL INTLIN(TEM1,ICHPO2,ICHPO3,NF,N1,N2,FTEM1,IRETOU) IF (IRETOU.EQ.0) THEN INTERR(1) = IP CALL ERREUR(428) SEGDES MLREE1 SEGDES MLREE2 SEGDES ICHARG SEGDES MJONCT GOTO 10 ENDIF ENDIF * DO 120 I3 = 1,NP IPOIN = NUMO(I3) COMP = NUDDL(I3) CALL EXTRA9(ICHP,IPOIN,COMP,0,.FALSE.,XFLOT1,IRET) IF (IRET.NE.1) THEN IF (ICHAR.NE.0) THEN SEGDES MLREE1 SEGDES MLREE2 SEGDES ICHARG ENDIF INTERR(1) = IP CALL ERREUR(428) SEGDES MJONCT GOTO 10 ENDIF XVAL = XFLOT1 * FTEM1 * IF (IIMPI.EQ.1804) THEN PRINT*,'-- PRISE EN COMPTE DES PSEUDO-MODES -- XVAL :',XVAL ENDIF * MLREE3 = KLIST(I3) MLREE3.PROG(IT) = MLREE3.PROG(IT) + XVAL 120 CONTINUE * 110 CONTINUE IF (ICONT.EQ.1) THEN MCHPO1=ICHP SEGSUP MCHPO1 ENDIF IF (ICHAR.NE.0) THEN SEGDES MLREE1 SEGDES MLREE2 SEGDES ICHARG ENDIF SEGDES MJONCT * 10 CONTINUE * SEGDES MLREEL SEGDES MSOLE1 SEGDES MSOLEN SEGDES MSOLUT IF (ILEX.NE.0) THEN SEGDES MSOLE2 ENDIF IF (ICHAR.NE.0) THEN SEGDES MCHARG ENDIF DO 4 I = 1,NP MLREE3 = KLIST(I) SEGDES MLREE3 4 CONTINUE * * SEGDES NUMOO IBOO = NUMOO * RETURN END