C CHAPO SOURCE OF166741 25/12/09 21:15:02 12415 C SUBROUTINE CHAPO(IPMODL,IPCHAM,IPCARA,IPCHPO,IRET) 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 PPARAM -INC CCOPTIO -INC SMMODEL -INC SMCHAML c -INC SMCHPOI -INC SMELEME -INC SMCOORD -INC SMINTE -INC TMPTVAL -INC TMTRAV SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) 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*(NCONCH) CONM ************************************************************************ * PRELIMINAIRES ************************************************************************ IRET=1 IPCHPO = 0 IDIMP1 = IDIM + 1 SEGACT MCOORD*MOD * ACTIVATION DU MMODEL et MCHAML MMODEL=IPMODL NSOUS=KMODEL(/1) MCHELM=IPCHAM NSC = mchelm.INFCHE(/1) IF (NSC .EQ. 0) THEN write(IOIMP,*) 'CHAPO : MCHAML VIDE' call erreur(21) c retourner un CHPOINT vide RETURN ENDIF * Verification du support : noeuds ou points d'integration (Gauss) ? ISUP = INFCHE(1,6) DO ISC = 2, NSC ISUP1 = INFCHE(ISC,6) IF (ISUP1.NE.ISUP) ISUP = 0 ENDDO * 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 IF (ISUP.LE.1.OR.ISUP.GT.6) THEN write(IOIMP,*) 'Supports incoherents',(INFCHE(isc,6),isc=1,NSC) call erreur(609) RETURN ENDIF c On recupere TITCH1 dimensionne a 72 comme MOCHDE du SMCHPOI LTIT1 = min(LTIT,TITCHE(/1)) TITCH1(1:LTIT1) = TITCHE(1:LTIT1) c Segment MTRAV et ses dimensions NNIN =0 NNNOE=0 MTRAV=0 nbtype = 1 SEGINI,notype notype.TYPE(1) = 'REAL*8' MOTYR8 = notype ************************************************************************ * Boucle sur les zones du MCHAML ************************************************************************ isous = 0 DO 100 ISOU = 1,NSOUS MELVEP = 0 IMODEL = KMODEL(ISOU) IPMAIL = IMAMOD CONM = CONMOD MELE = NEFMOD MELEME = IPMAIL c write(6,*) '==== zone',ISOU,'/',NSOUS,' itypel =',itypel IF (itypel.eq.48) goto 100 isous = isous+1 c write(6,*) ' => zone ok : ISOUS=', ISOUS * RECUP DU SEGMENT D'INTEGRATION MINTE if (infmod(/1).lt.7) then write(ioimp,*) 'chapo : infmod(/1) < 7' call erreur(5) endif c* NBGS = INFELE(4) MFR = INFELE(13) MINTE = INFMOD(ISUP+2) MINTE1 = INFMOD(3) c*Active par ACTOBJ : SEGACT,minte c*Active par ACTOBJ : IF (ISUP.GE.5.AND.MFR.EQ.5) SEGACT,minte1 CALL IDENT(IPMAIL,CONM,IPCHAM,0,INFOS,IRET) c IF (IRET.EQ.0) call erreur(5) NBN1 = meleme.NUM(/1) NBELE1 = meleme.NUM(/2) facz = 1.D0 NBOUC = NBN1 IF (ISUP.EQ.1) THEN NIPO = NBN1 ELSE NBPGAU = minte.POIGAU(/1) NIPO = NBPGAU C ON DOIT DIVISER PAR 2 POUR CERTAINS ELEMENTS DE JOINTS UNIQUEMENT C SI LE SUPPORT EST DIFFERENT DE 1 (VOIR AUSSI CHELCO.ESO) C ELEMENTS DE FORMULATION : MFR = 35 ity = meleme.ITYPEL IF ( ity.EQ.12 .OR. ity.EQ.18 .OR. ity.EQ.19 .OR. & ity.EQ.20 .OR. ity.EQ.21 .OR. ity.EQ.29 .OR. & ity.EQ.30 .OR. ity.EQ.31 ) THEN facz = 0.5D0 IF (ity.EQ.29) NBOUC = 6 IF (ity.EQ.30) NBOUC = 12 IF (ity.EQ.31) NBOUC = 16 ENDIF ENDIF IF (MFR.EQ.5) THEN IF (IPCARA.EQ.0) THEN MOTERR(1:16) = 'CARACTERISTIQUES' CALL ERREUR(565) write(ioimp,*) 'erreur manque IPCARA' RETURN ENDIF * Cas des coques epaisses : recup de l'epaisseur * on neglige l'excentrement IF (ISUP.GE.5) THEN NBROBL = 1 NBRFAC = 0 SEGINI,nomid LESOBL(1) = 'EPAI' MOEP = nomid CALL KOMCHA(IPCARA,IPMAIL,CONM,MOEP, & MOTYR8,1,INFOS,3,IVAEP) SEGSUP,nomid IF (IERR.NE.0) RETURN mptval = IVAEP MELVEP = IVAL(1) SEGSUP,mptval ENDIF 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) 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 INCO(IC) = NOMCHE(IC) 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(INCO(IIN).NE.NOMCHE(IC)) GOTO 102 IF(NHAR(IIN).EQ.INFCHE(ISOU,3)) THEN KINCO(IC)=IIN GOTO 101 ENDIF 102 CONTINUE c nouvelle composante ! NCNEW=NCNEW+1 INCO(NCNEW)=NOMCHE(IC) 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 ! 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) ** * recup de la position IIN dans MTRAV DO 151 IIN=1,NNIN IF(INCO(IIN).EQ.NOMCHE(IC)) GOTO 152 151 CONTINUE CALL ERREUR(5) RETURN 152 CONTINUE * + debut des nouveaux noeuds INOE = NNNOE1 *---------- 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 MELVA1=MELVEP 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 CALL CQ8LOC(XEL,NBN1,MINTE1.SHPTOT,TXR,IRR) 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) * 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 = 0.5D0 * DZEGAU(IPSU) DO I2 = 1, IDIM r_z = 0.D0 DO IL = 1,NBN1 r_z = r_z + (SHPTOT(1,IL,IPSU)* & XEL(I2,IL)+ Z*TXR(I2,3,IL)*TH(IL)) ENDDO XIGAU(I2) = r_z ENDDO ELSE DO I2 = 1, IDIM r_z = 0.D0 DO IL = 1, NBOUC r_z = r_z + SHPTOT(1,IL,IPSU)*XEL(I2,IL) ENDDO XIGAU(I2) = facz * r_z ENDDO ENDIF * Le pdi est cree dans MCOORD KPTS=(IGEO(INOE)-1)*IDIMP1 XCOOR(KPTS+1) = XIGAU(1) XCOOR(KPTS+2) = XIGAU(2) IF (IDIM.EQ.3) XCOOR(KPTS+3)=XIGAU(3) XCOOR(KPTS+IDIMP1) = 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 ************************************************************************ CALL CRECHP (MTRAV,IPCHPO) SEGSUP,MTRAV 900 CONTINUE notype = MOTYR8 SEGSUP,notype SEGDES,MCOORD C RETURN END