chapo
C CHAPO SOURCE CB215821 20/11/25 13:19:19 10792 C C======================================================================= C C TRANSFORME LE MCHAML IPCHAM EN CHPOINT IPCHPO C il y a deja eu un reduaf sur IPMODL du mchaml -> IPCHAM C C======================================================================= IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC SMMODEL -INC SMCHAML c -INC SMCHPOI -INC SMELEME -INC SMCOORD -INC PPARAM -INC CCOPTIO -INC SMINTE -INC TMTRAV * 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 c tableau inverse pour retrouver la position d'inconnue SEGMENT KINCO(NINCO) SEGMENT MWRK1 REAL*8 XEL(3,NBN1) ENDSEGMENT SEGMENT MWRK2 REAL*8 TXR(3,3,NBN1),TH(NBN1) ENDSEGMENT PARAMETER (LTIT=72) CHARACTER*(LTIT) TITCH1 DIMENSION XIGAU(3) DIMENSION INFOS(3) * CHARACTER*(LCONMO) CONM CHARACTER*(NCONCH) CONM ************************************************************************ * PRELIMINAIRES ************************************************************************ SEGACT MCOORD*MOD * * ACTIVATION DU MMODEL et MCHAML * IRET=1 MMODEL=IPMODL MCHELM=IPCHAM SEGACT,MMODEL,MCHELM NSOUS=KMODEL(/1) IF(IPCARA.GT.0) THEN MCHEL1=IPCARA SEGACT,MCHEL1 ENDIF * * Verification du support : noeuds ou points d'integration (Gauss) ? * 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 = 2 : MCHAML au centre de gravite * si ISUP = 3 : MCHAML aux point d integration (rigidite) * si ISUP = 4 : MCHAML aux point d integration (masse) * si ISUP = 5 : MCHAML aux point d integration (stresses) * si ISUP = 6 : MCHAML aux point d integration de T cbp IF (ISUP.LT.1.OR.ISUP.GT.6) THEN IF (ISUP.LE.1.OR.ISUP.GT.6) THEN write(IOIMP,*) 'Supports incoherents',(INFCHE(iou,6),iou=1,NSC) RETURN ENDIF c on recupere TITCH1 dimensionné à 72 comme MOCHDE du SMCHPOI LTIT1 = min(LTIT,TITCHE(/1)) TITCH1(1:LTIT1) = TITCHE(1:LTIT1) TITCH1(1:LTIT1) = TITCHE(1:LTIT1) c * liste des composantes c * ... c c * Creation du MCHPOI puis du MSOUPO et du MPOVAL c * c NAT = 2 c NSOUPO = 1 c SEGINI MCHPOI c IPCHPO = MCHPOI c MTYPOI = 'CHAN CHPO' c MOCHDE(1:LTIT1) = TITCH1(1:LTIT1) c IFOPOI = IFOUR c JATTRI(1) = 2 c JATTRI(2) = 0 c Segment MTRAV et ses dimensions NNIN=0 NNNOE=0 MTRAV=0 ************************************************************************ * Boucle sur les zones du MCHAML ************************************************************************ isous = 0 DO 100 ISOU = 1,NSOUS cbp IVACOM = 0 IVAEP = 0 * ACTIVATION DU SOUS MODELE c IMODEL = KMODEL(ISOU) IIIMOD = KMODEL(ISOU) IMODEL = IIIMOD SEGACT IMODEL IPMAIL = IMAMOD CONM = CONMOD MELE = NEFMOD MELEME = IMAMOD SEGACT,MELEME NFOR = FORMOD(/2) NMAT = MATMOD(/2) c write(6,*) '==== zone',ISOU,'/',NSOUS,' itypel =',itypel IF (itypel.eq.48) goto 100 isous = isous+1 c write(6,*) ' => zone ok : ISOUS=', ISOUS * cbp CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT) * * RECUP DU SEGMENT D'INTEGRATION MINTE if(infmod(/1).lt.7) then ISUP5 = MIN(ISUP,5) IF (IERR.NE.0) THEN write(*,*) 'erreur apres elquoi' 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(ISUP+2) MINTE1 = INFMOD(8) endif * IPMINT = MINTE IF (MFR.EQ.5.AND.IPCARA.EQ.0) THEN MOTERR(1:16) = 'CARACTERISTIQUES' write(*,*) 'erreur manque IPCARA' RETURN ENDIF IF (ISUP.GE.5.AND.MFR.EQ.5) SEGACT MINTE1 * c IF (IRET.EQ.0) call erreur(5) * SEGACT MINTE NBPGAU = POIGAU(/1) c SEGACT MELEME NBN1 = NUM(/1) NBELE1 = NUM(/2) IF (ISUP.EQ.1) THEN NIPO = NBN1 ELSE NIPO = NBPGAU ENDIF * creation des segments de travail SEGINI MWRK1 NPPO = NIPO * NBELE1 c write(6,*) 'nb pts support', NIPO, '* nb elem',NBELE1,'=',NPPO IF (ISUP.GE.5.AND.MFR.EQ.5) SEGINI MWRK2 * ACTIVATION DU SOUS-MCHELM MCHAML MCHAML = ICHAML(ISOUS) SEGACT,MCHAML NC=IELVAL(/1) * * CREATION/AJUSTEMENT DU MTRAV * + REMPLISSAGE DE INCO et de KINCO NINCO=NC SEGINI,KINCO c -1er passage : IF(ISOUS.EQ.1) THEN NNIN =NC NNNOE1=0 NNNOE=NPPO SEGINI,MTRAV c toutes les composantes sont nouvelles DO IC=1,NC NHAR(IC)=INFCHE(ISOU,3) KINCO(IC)=IC ENDDO c -passages suivants : ELSE c on dimensionne au plus large NNIN1=NNIN NNIN =NNIN+NC NNNOE1=NNNOE NNNOE=NNNOE+NPPO SEGADJ,MTRAV c recherche des composantes nouvelles C pour MCHAML NCNEW=0 DO 101 IC=1,NC DO 102 IIN=1,NNIN1 IF(NHAR(IIN).EQ.INFCHE(ISOU,3)) THEN KINCO(IC)=IIN GOTO 101 ENDIF 102 CONTINUE c nouvelle composante ! NCNEW=NCNEW+1 NHAR(NCNEW)=INFCHE(ISOU,3) KINCO(IC)=NCNEW 101 CONTINUE c on remet a la bonne taille NNIN=NNIN1+NCNEW SEGADJ,MTRAV ENDIF * + REMPLISSAGE DE IGEO et de IBIN c sympa: a priori, tous les noeuds sont nouveaux ! NBPTS1 = NBPTS DO INOE=NNNOE1+1,NNNOE NBPTS=NBPTS+1 IGEO(INOE)=NBPTS do IC=1,NC IIN=KINCO(IC) IBIN(IIN,INOE)=1 enddo ENDDO SEGADJ,MCOORD c WRITE(*,*) 'INCO=',(INCO(iou),iou=1,NNIN) c IN NE RESTE QU'A REMPLIR BB... * *======================================================================= * Boucle sur les composantes * DO 150 IC = 1,NC c write(6,*) '============ ISOU,IC=',ISOU,IC,'IMODEL=',IMODEL * Recup du melval MELVAL=IELVAL(IC) SEGACT,MELVAL ** * Cas des coques epaisses : recup de l'epaisseur * on neglige l'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' & MOTYPE,1,INFOS,3,IVAEP) SEGSUP NOTYPE ENDIF * * recup de la position IIN dans MTRAV DO 151 IIN=1,NNIN 151 CONTINUE RETURN 152 CONTINUE * + debut des nouveaux noeuds INOE = NNNOE1 * *---------- Boucle sur les elements ------------------------------ * DO 200 IEL = 1,NBELE1 * cas general * * coques epaisses IF (ISUP.GE.5.AND.MFR.EQ.5) THEN MPTVAL=IVAEP MELVA1=IVAL(1) DO 201 IP = 1,NBN1 IPMN=MIN(IP ,MELVA1.VELCHE(/1)) IEMN=MIN(IEL,MELVA1.VELCHE(/2)) TH(IP)=MELVA1.VELCHE(IPMN,IEMN) 201 CONTINUE ENDIF * *............. Boucle sur les points supports ............. * DO 300 IPSU = 1,NIPO * remplissage des valeurs CHAMELEM -> MTRAV IPMN = MIN(IPSU,VELCHE(/1)) IEMN = MIN(IEL ,VELCHE(/2)) INOE=INOE+1 BB(IIN,INOE) = VELCHE(IPMN,IEMN) * cbp c IF (ISUP.GE.5) THEN cbp IF (ISUP.GT.1) 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 IL = 1,NBN1 400 CONTINUE ELSE DO 410 IL = 1,NBN1 410 CONTINUE ENDIF * Le pdi est cree dans MCOORD KPTS=IGEO(INOE) XCOOR((KPTS-1)*(IDIM+1)+1) = XIGAU(1) XCOOR((KPTS-1)*(IDIM+1)+2) = XIGAU(2) IF (IDIM.EQ.3) XCOOR((KPTS-1)*(IDIM+1)+3)=XIGAU(3) XCOOR(KPTS*(IDIM+1)) = 0.D0 ENDIF 300 CONTINUE *............. fin de Boucle sur les points supports .......... 200 CONTINUE *---------- Fin de Boucle sur les elements ----------------------- 150 CONTINUE * Fin de Boucle sur les composantes *======================================================================= * Desactivation des segments de la zone ISOU * SEGSUP MWRK1 IF (ISUP.GE.5.AND.MFR.EQ.5) SEGSUP MWRK2 SEGSUP,KINCO * 100 CONTINUE ************************************************************************ * FIN DE Boucle sur les zones du MCHAML ************************************************************************ ************************************************************************ * CREATION DU CHPOINT FINAL A PARTIR DU MTRAV ************************************************************************ SEGSUP,MTRAV IPCHPO=IPCHP1 END
© Cast3M 2003 - Tous droits réservés.
Mentions légales