C VECTE4 SOURCE BP208322 13/06/27 21:15:17 7782 C SUBROUTINE VECTE4(MCHA1,MCHA2,MOD1,AMP,LMOT0,LMOT1,MVECT0) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) *---------------------------------------------------------------* * Creation d'un MVECTE a partir d'un MCHAML en vue * * d'un trace avec des petites fleches * * Largement inspiré de VECTE2 * * * * MCHA1 MCHAML * * MCHA2 MCHAML de CARACTERISTIQUES (coques epaisses) * * MOD1 MMODEL * * AMP coefficient d'amplification (FLOTTANT) * * LMOT0 liste des composantes a visualiser * * LMOT1 liste des couleurs affectees aux composantes * * MVECT0 pointeur sur MVECTE resultat * * * * CREATION , MODIFICATIONS : * * + Benoit Prabel, 01/03/2012 * * + Benoit Prabel, 19/06/2013 : on remplace les "ISUP.EQ.5"* * par des "ISUP.GE.5" ... * *---------------------------------------------------------------* -INC CCOPTIO -INC CCGEOME -INC SMCHPOI -INC SMCHAML -INC SMMODEL -INC SMVECTE -INC SMELEME -INC SMINTE -INC SMCOORD -INC SMLMOTS * SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT SEGMENT MPTVAL INTEGER IPOS(NS),NSOF(NS),IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT SEGMENT INFO INTEGER INFELL(JG) ENDSEGMENT SEGMENT IPPO(NPPO) SEGMENT MWRK1 REAL*8 XEL(3,NBN1) ENDSEGMENT SEGMENT MWRK2 REAL*8 TXR(3,3,NBN1),TH(NBN1) ENDSEGMENT * PARAMETER (NINF = 3) INTEGER INFOS(NINF) DIMENSION XIGAU(3),MOCOMP(3) CHARACTER*(NCONCH) CONM CHARACTER*8 CMATE CHARACTER*4 NOMVEC(6) PARAMETER (LTIT=72) CHARACTER*(LTIT) TITCH1 DATA NOMVEC/'VEC1','VEC2','VEC3','VEC4','VEC5','VEC6'/ c CHARACTER*4 NOMVEC(3) c DATA NOMVEC/'SI11','SI22','SI33'/ ************************************************************************ * Preliminaires ************************************************************************ MVECT0 = 0 SMAX = 0.D0 * MCHELM = MCHA1 SEGACT MCHELM * * Verification du support : noeuds ou pdi ? * ISUP = INFCHE(1,6) NSC = INFCHE(/1) DO 50 ISC=2,NSC ISUP1 = INFCHE(ISC,6) IF (ISUP1.NE.ISUP) ISUP = 0 50 CONTINUE * si ISUP = 1 : MCHAML aux noeuds * si ISUP = 5 : MCHAML aux point d integration * si ISUP = 6 : MCHAML aux point d integration de T IF (ISUP.NE.1.AND.ISUP.NE.5.AND.ISUP.NE.6) THEN write(6,*) 'vecte4: Support ISUP=',ISUP call erreur(609) SEGDES MCHELM RETURN ENDIF c on recupere TITCH1 dimensionné ŕ 72 comme MOCHDE du SMCHPOI LTIT1 = min(LTIT,TITCHE(/1)) TITCH1(1:LTIT1) = TITCHE(1:LTIT1) SEGDES MCHELM * liste des composantes NMO0 = 0 IF (LMOT0.NE.0) THEN MLMOT4 = LMOT0 SEGACT MLMOT4 NMO4 = MLMOT4.MOTS(/2) ENDIF NLIST = NMO4/idim * creation des NLIST nomid correspondants (meme role que IDVEC2) c NBROBL = idim+1 NBROBL = idim NBRFAC = 0 imo4=0 do ilist=1,NLIST SEGINI NOMID MOCOMP(ilist)=NOMID c LESOBL(1) = NOMVEC(ilist) c do iobl=2,NBROBL do iobl=1,NBROBL imo4=imo4+1 LESOBL(iobl)=MLMOT4.MOTS(imo4) enddo c write(6,*)'ilist,LESOBL=',ilist,' ',(LESOBL(iou),iou=1,NBROBL) SEGDES NOMID enddo NCOMP=NBROBL * liste des couleurs NMO = 0 IF (LMOT1.NE.0) THEN MLMOTS = LMOT1 SEGACT MLMOTS NMO = MOTS(/2) if (NMO.ne.NLIST) then write(ioimp,*) 'Incoherence dans la dimension de la liste', & 'des couleurs fournies : On l oublie.' segdes,MLMOTS MLMOTS=0 LMOT1=0 NMO=0 endif ENDIF * MMODEL = MOD1 SEGACT MMODEL NSOUS = KMODEL(/1) ************************************************************************ * Boucle sur les zones du MCHAML ************************************************************************ DO 100 ISOU = 1,NSOUS IVACOM = 0 IVAEP = 0 IMODEL = KMODEL(ISOU) SEGACT IMODEL IPMAIL = IMAMOD CONM = CONMOD MELE = NEFMOD MELEME = IMAMOD NFOR = FORMOD(/2) NMAT = MATMOD(/2) * CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT) * if(infmod(/1).lt.7) then CALL ELQUOI(MELE,0,5,IPINF,IMODEL) IF (IERR.NE.0) THEN SEGDES IMODEL,MMODEL RETURN ENDIF INFO = IPINF NBGS = INFELL(4) MFR = INFELL(13) MINTE = INFELL(11) MINTE1 = INFELL(12) segsup info else NBGS = INFELE(4) MFR = INFELE(13) MINTE=INFMOD(7) MINTE1 = INFMOD(8) endif * IPMINT = MINTE IF (MFR.EQ.5.AND.MCHA2.EQ.0) THEN MOTERR(1:16) = 'CARACTERISTIQUES' CALL ERREUR(565) SEGDES IMODEL,MMODEL RETURN ENDIF IF (ISUP.GE.5.AND.MFR.EQ.5) SEGACT MINTE1 * CALL IDENT(IPMAIL,CONM,MCHA1,0,INFOS,IRET) IF (IRET.EQ.0) GOTO 900 * SEGACT MINTE NBPGAU = POIGAU(/1) SEGACT MELEME NBN1 = NUM(/1) NBELE1 = NUM(/2) IF (ISUP.EQ.1) NIPO = NBN1 IF (ISUP.GE.5) NIPO = NBPGAU SEGINI MWRK1 NPPO = NIPO * NBELE1 IF (ISUP.GE.5) SEGINI IPPO IF (ISUP.GE.5.AND.MFR.EQ.5) SEGINI MWRK2 * * Listes de composantes attendues * c CALL IDVEC2(IMODEL,1,IDIM,0,CMOT,MOCOMP,NCOMP, c & NLIST,IER1) c IF (IER1.NE.0) THEN c IF (IER1.EQ.1) call erreur(19) c IF (IER1.EQ.2) THEN c moterr(1:4) = CMOT c call erreur(197) c ENDIF c SEGDES IMODEL,MMODEL c RETURN c ENDIF * IF (NMO.NE.0) THEN IF (LMOT1.NE.0.AND.NLIST.NE.NMO) GOTO 900 ENDIF * c NVEC = NLIST * 2 NVEC = NLIST ID = 1 SEGINI MVECTE * *======================================================================= * Boucle sur les listes de composantes * DO 150 IC = 1,NLIST c write(6,*) ' ' c write(6,*) '============ ISOU,IC=',ISOU,IC,' ============' NOMID = MOCOMP(IC) SEGACT NOMID IC2=IC c on ecrit pas le noms des composantes, mais de la liste de composante... NOCOVE(IC,1) = NOMVEC(IC) IF (LMOT1.EQ.0) THEN NOCOUL(IC) = IC+1 ELSE ICOUL=IDCOUL+1 CALL PLACE(NCOUL,NBCOUL,ICOUL,MOTS(IC)) NOCOUL(IC) = ICOUL-1 ENDIF c write(6,*) 'NOCOUL=',(NOCOUL(iou),iou=1,NLIST) IGEOV(IC) = 0 * * Creation du MCHPOI puis du MSOUPO et du MPOVAL * NAT = 2 NSOUPO = 1 SEGINI MCHPOI ICHPO(IC) = MCHPOI MTYPOI = 'VECTEUR ' MOCHDE(1:LTIT1) = TITCH1(1:LTIT1) IFOPOI = IFOUR JATTRI(1) = 2 JATTRI(2) = 0 NC = IDIM SEGINI MSOUPO IPCHP(1) = MSOUPO NOCOMP(1) = 'VECX' NOCOMP(2) = 'VECY' IF (IDIM.EQ.3) NOCOMP(3) = 'VECZ' * N = NIPO * NBELE1 SEGINI MPOVAL IPOVAL = MPOVAL * NBNN = 1 NBELEM = N NBSOUS = 0 NBREF = 0 SEGINI IPT1 IGEOC = IPT1 IPT1.ITYPEL = 1 * NBTYPE = 1 SEGINI NOTYPE MOTYPE = NOTYPE TYPE(1) = 'REAL*8' CALL KOMCHA(MCHA1,IPMAIL,CONM,MOCOMP(IC), & MOTYPE,1,INFOS,3,IVACOM) SEGSUP NOTYPE IF (IERR.NE.0) GOTO 900 * * Cas des coques epaisses : epaisseur (excentrement) * IF (ISUP.GE.5.AND.MFR.EQ.5) THEN NBROBL = 1 NBRFAC = 0 SEGINI NOMID MOEP = NOMID LESOBL(1) = 'EPAI' NVEC = NBROBL + NBRFAC NBTYPE = 1 SEGINI NOTYPE MOTYPE = NOTYPE TYPE(1) = 'REAL*8' CALL KOMCHA(MCHA2,IPMAIL,CONM,MOEP, & MOTYPE,1,INFOS,3,IVAEP) SEGSUP NOTYPE ENDIF * IPO = 0 * *---------- Boucle sur les elements ------------------------------ * DO 200 IEL = 1,NBELE1 * * cas general CALL DOXE(XCOOR,IDIM,NBN1,NUM,IEL,XEL) * * coques epaisses IF (ISUP.GE.5.AND.MFR.EQ.5) THEN MPTVAL = IVAEP MELVAL=IVAL(1) DO 201 IP = 1,NBN1 IPMN=MIN(IP ,VELCHE(/1)) IEMN=MIN(IEL,VELCHE(/2)) TH(IP)=VELCHE(IPMN,IEMN) 201 CONTINUE CALL CQ8LOC(XEL,NBN1,MINTE1.SHPTOT,TXR,IRR) ENDIF * *............. Boucle sur les points supports ............. * DO 300 IPSU = 1,NIPO IPO = IPO + 1 * MPTVAL = IVACOM * DO 350 I1 = 1,IDIM MELVAL = IVAL(I1) IPMN = MIN(IPSU,VELCHE(/1)) IEMN = MIN(IEL ,VELCHE(/2)) COS1 = VELCHE(IPMN,IEMN) VPOCHA(IPO,I1) = COS1 350 CONTINUE * IF (ISUP.GE.5) THEN * 1er passage : on calcule les coord du pt d integration IF (IC.EQ.1) THEN IF (ISUP.GE.5.AND.MFR.EQ.5) THEN Z = DZEGAU(IPSU) DO 400 I2 = 1,IDIM XIGAU(I2) = 0.D0 DO 400 IL = 1,NBN1 XIGAU(I2) = XIGAU(I2)+(SHPTOT(1,IL,IPSU)* & XEL(I2,IL)+0.5D0*Z*TXR(I2,3,IL)*TH(IL)) 400 CONTINUE ELSE DO 410 I2 = 1,IDIM XIGAU(I2) = 0.D0 DO 410 IL = 1,NBN1 XIGAU(I2) = XIGAU(I2) + & (SHPTOT(1,IL,IPSU)*XEL(I2,IL)) 410 CONTINUE ENDIF * * Le pdi est reference dans MCOORD (PROVISOIRE) NBPTS = XCOOR(/1)/(IDIM+1)+1 SEGADJ MCOORD XCOOR((NBPTS-1)*(IDIM+1)+1) = XIGAU(1) XCOOR((NBPTS-1)*(IDIM+1)+2) = XIGAU(2) IF (IDIM.EQ.3) XCOOR((NBPTS-1)*(IDIM+1)+3)=XIGAU(3) XCOOR(NBPTS*(IDIM+1)) = 0.D0 IPT1.NUM(1,IPO) = NBPTS IPPO(IPO) = NBPTS * passage suivant : on recupere les coord du pdi ELSE IPT1.NUM(1,IPO) = IPPO(IPO) ENDIF ELSE IPT1.NUM(1,IPO) = NUM(IPSU,IEL) ENDIF 300 CONTINUE *............. fin de Boucle sur les points supports .......... 200 CONTINUE *---------- Fin de Boucle sur les elements ----------------------- SEGDES MPOVAL,MSOUPO,MCHPOI,IPT1 151 SEGDES NOMID 150 CONTINUE * Fin de Boucle sur les composantes *======================================================================= c IC1 = 0 c DO 500 IC2 = NLIST+1,NLIST*2 c IC1 = IC1 + 1 c NOCOVE(IC2,1) = NOMVEC(IC1) c IF (LMOT1.EQ.0) THEN c NOCOUL(IC2) = IC1 + 1 c ELSE c ICOUL=IDCOUL+1 c CALL PLACE(NCOUL,NBCOUL,ICOUL,MOTS(IC1)) c NOCOUL(IC2) = ICOUL-1 c ENDIF c IGEOV(IC2) = 0 c MCHPOI = ICHPO(IC1) c CALL MUCHPO(MCHPOI,-1.D0,ICHP2,1) c ICHPO(IC2) = ICHP2 c 500 CONTINUE * * Desactivation des segments de la zone ISOU * SEGDES IMODEL,MINTE,MELEME IF (MFR.EQ.5) SEGDES MINTE1 DO 105 I0 = 1,NCOMP IF (IVAL(I0).NE.0) THEN MELVAL = IVAL(I0) SEGDES,MELVAL ENDIF 105 CONTINUE SEGSUP MPTVAL,MWRK1 IF (ISUP.GE.5.AND.MFR.EQ.5) SEGSUP MWRK2 IF (ISUP.GE.5) SEGSUP IPPO c NCX = NLIST * 2 NCX = NLIST c IF (CMOT.NE.' ') NCX = 2 DO 101 IMX = 1,NCX AMPF(IMX) = AMP 101 CONTINUE SEGDES MVECTE * IF (MVECT0.EQ.0) THEN MVECT0 = MVECTE ELSE CALL FUSVEC(MVECT0,MVECTE,MVECT1) MVECT0 = MVECT1 ENDIF * 100 CONTINUE SEGDES MMODEL IF (LMOT1.NE.0) SEGDES MLMOTS RETURN * 900 CONTINUE * RETURN END