C PROJTA SOURCE CB215821 20/11/25 13:37:19 10792 SUBROUTINE PROJTA(IP1,IPMOD,IPSTA,IRET) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) ************************************************************************ * * * PROJECTION DU CHAMP IP1 SUR LES ELEMENTS DE LA BASE MODALE IP2 * * * * PARAMETRES: * * * * E IP1 chpoint second membre * * E IPMOD table des modes de sous-type base_de_modes * * E IPSTA table des modes de sous-type liaisons_statiques * * S IRET chpoint resultat * * * * REMARQUES: * * * * ce sous-programme est une copie de projba * * ce sous-programme est appele par pjba, psmo, copba4 * * * * AUTEUR, DATE DE CREATION : lionel vivan, aout 1990 * * MODIFS : ajout des liaisons statiques (BP, 05/08/2014) * * amelioration compatibilite (BP, 2015-09-24) * * * ************************************************************************ * -INC PPARAM -INC CCOPTIO -INC CCGEOME -INC CCREEL -INC SMCHPOI -INC SMELEME -INC CCHAMP * SEGMENT ICPR(nbpts) SEGMENT IINC CHARACTER*(LOCOMP) CIINC(0) ENDSEGMENT SEGMENT IINC2 CHARACTER*(LOCOMP) CIINC2(NNI1) ENDSEGMENT SEGMENT/MVA/(VA(NNI1,IPR1)*D),MVA1.MVA SEGMENT IPB(IPR1) SEGMENT MCONTR(NNI1,IPR1) LOGICAL L0,L1 CHARACTER*(LOCOMP) IDDL CHARACTER*8 TYPRET,CHARRE CHARACTER*15 MODEFO DATA KZERO/0/ * IRET = 0 ***** s'agit-il d'un second membre de type deplacement impose ? ***** * * deplacement impose => idepi=1 * force imposee => idepi=0 IDEPI = 0 * idepi = -1 KDEPI = 0 MCHPOI = IP1 IF (MTYPOI.EQ.'FLX ') IDEPI = 1 * bp: ce test ne semble pas tres robuste... --> a revisiter + tard... * if(mtypoi(1).eq.moforc(1).and.mtypoi(2).eq.moforc(2)) idepi=0 * if (idepi.lt.0) then * moterr(1:8) = 'chpoint' * call erreur(302) * return * endif * ***** etalpr de IP1 : chpoint 2nd membre F ***** * CALL ETALPR(IP1,KIINC,KICPR,KCONTR) IF(IERR.NE.0) RETURN * on recupere le MCONTR MCONTR = KCONTR SEGACT MCONTR NNI1 = MCONTR(/1) IPR1 = MCONTR(/2) * on cree 2 MVA : KMVA pour les X_i et KMVB pour F SEGINI MVA KMVA = MVA SEGINI MVA KMVB = MVA c * on cree un IPB pour les X_i c SEGINI IPB c KIPB = IPB c SEGDES IPB * on remplit le MVA de KMVB avec les valeurs de F: * on etale F dans KMVB CALL ETALCH(IP1,KIINC,KICPR,KCONTR,KMVB,KZERO,NPR2,1) * fabrication de la liste des inconnues primales IINC2 * correspondant aux duales IINC IINC = KIINC SEGINI IINC2 DO 6 I = 1,NNI1 IDDL = CIINC(I) DO 7 J = 1,LNOMDD IF(IDDL.NE.NOMDU(J)) GOTO 7 CIINC2(I) = NOMDD(J) GOTO 6 7 CONTINUE MOTERR = IDDL CALL ERREUR(108) * on ne trouve pas iddl dans CCHAMP RETURN 6 CONTINUE KIINC2 = IINC2 * * ***** on initialise le chpoint de sortie ***** * if (IPSTA.gt.0) then NSOUPO = 2 else NSOUPO = 1 endif NAT=1 SEGINI,MCHPOI IRET = MCHPOI MTYPOI = ' ' MOCHDE=' J''AI ETE FABRIQUE PAR PJBA' IFOPOI = IFOUR * champ de force nodal: nature discrete JATTRI(1)=2 *---- boucle sur ISOUPO (=sur les composantes FALF et FBET) ---- DO 100 ISOUPO=1,NSOUPO if(ISOUPO.eq.1) then IP2 = IPMOD MODEFO(1:15) = 'DEFORMEE_MODALE' else IP2 = IPSTA MODEFO(1:15) = 'DEFORMEE' endif if(iimpi.ge.333) write(ioimp,*) ISOUPO,IP2,MODEFO * ***** on compte le nombre de modes ***** LDEPL = 0 10 CONTINUE LDEPL = LDEPL + 1 TYPRET = ' ' CALL ACCTAB(IP2,'ENTIER',LDEPL,X0,' ',L0,IP0, & TYPRET,I1,X1,CHARRE,L1,ITMOD) IF(IERR.NE.0) RETURN IF (TYPRET.EQ.'TABLE ' .AND. ITMOD.NE.0) GOTO 10 LDEPL = LDEPL - 1 if(iimpi.ge.333) write(ioimp,*) 'nombre de modes=',LDEPL ***** on initialise le MSOUPO du chpoint de sortie ***** NC = 1 SEGINI,MSOUPO IPCHP(ISOUPO) = MSOUPO if(ISOUPO.eq.1) then NOCOMP(1) = 'FALF' else NOCOMP(1) = 'FBET' endif NOHARM(1) = NIFOUR N = LDEPL SEGINI MPOVAL IPOVAL = MPOVAL * NBNN = 1 NBELEM = LDEPL NBSOUS = 0 NBREF = 0 SEGINI MELEME IGEOC = MELEME ITYPEL = 1 * ***** boucle sur les chpoints de deformee X_i ***** * DO 11 IM = 1,LDEPL * recup du i eme mode (indice IM) CALL ACCTAB(IP2,'ENTIER',IM,X0,' ',L0,IP0, & 'TABLE',I1,X1,' ',L1,ITMOD) IF(IERR.NE.0) RETURN * recup du point repere CALL ACCTAB(ITMOD,'MOT',I0,X0,'POINT_REPERE',L0,IP0, & 'POINT',I1,X1,' ',L1,IPTR) IF(IERR.NE.0) RETURN * + ecriture du point dans le maillage du chpoint projete NUM(1,IM) = IPTR ICOLOR(IM) = IDCOUL * recup de la deformee X_i (chpoint IPP1) CALL ACCTAB(ITMOD,'MOT',I0,X0,MODEFO,L0,IP0, & 'CHPOINT',I1,X1,' ',L1,IPP1) IF(IERR.NE.0) RETURN CALL ACTOBJ('CHPOINT ',IPP1,1) * Calcul effectif du terme F^T * X_i XRET = 0.D0 * -force imposee => idepi=0 IF (IDEPI.NE.1) THEN * on etale X_i dans KMVA * selon le format defini par KIINC2, KICPR et KCONTR CALL ETALCH(IPP1,KIINC2,KICPR,KCONTR,KMVA,KZERO,IBID,0) IF (IERR.NE.0) RETURN * MVA = KMVA c IPB = KIPB MVA1 = KMVB * boucle sur les elements definis par F DO 80 J1 = 1,NPR2 c JJ1 = IPB(J1) DO 80 I1 = 1,NNI1 c XRET = XRET + VA(I1,JJ1) * MVA1.VA(I1,JJ1) XRET = XRET + VA(I1,J1) * MVA1.VA(I1,J1) 80 CONTINUE * -deplacement impose => idepi=1 ELSE CALL ACCTAB(ITMOD,'MOT',I0,X0,'FREQUENCE',L0,IP0, & 'FLOTTANT',I1,X1,' ',L1,IP1) IF(IERR.NE.0) RETURN OM = X1 OM = 2.D0 * XPI * OM OM = OM * OM XRET = -XRET / OM *bp XRET vaut toujours 0 !?!?! ENDIF VPOCHA(IM,1) = XRET 11 CONTINUE * 100 continue *---- fin de boucle sur ISOUPO (=sur les composantes FALF et FBET) ---- SEGSUP MVA,MVA1 c SEGSUP,IPB ICPR = KICPR SEGSUP ICPR,IINC,IINC2 * IF (IDEPI.NE.KDEPI) THEN *** la base ne contient pas la solution statique necessaire au *** calcul de la reponse au deplacement impose CALL ERREUR(303) CALL ECRCHA('GEOM') CALL DTCHPO(MCHPOI) IRET = 0 ENDIF * END