C MANUC7 SOURCE FANDEUR 13/01/29 21:16:00 7683 SUBROUTINE MANUC7(IPMODL,MLMOTS,IPOI,MONMOT,MLMOT3,MLMOT2, . LETYP,JER1,ISUP1,ICHA,itart) *------------------------------------------------------------------ * * CREATION D'UN MCHAML * *------------------------------------------------------------------ IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC SMCHAML -INC SMELEME -INC SMLMOTS -INC SMLREEL -INC SMLENTI -INC SMMODEL -INC SMINTE -INC CCOPTIO -INC CCGEOME * * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN) * ----------- * * MLENT1 (E) POINTEURS SUR ZONES ELEMENTAIRES DE MAILLAGE * MLMOTS (E) POINTEUR SUR UN LISTMOTS CONTENANT LES NOMS * MLMOT3 (E) POINTEUR SUR UN LISTMOTS CONTENANT LES TYPES * MLMOT2 (E) POINTEUR SUR UN LISTMOTS CONTENANT LES TYPES * DES CONSTITUANTS * IPOI (E) POINTEUR SUR UN LISTENTI OU UN LISTREEL * MONMOT (E) MOT DE 8 CARACTERES * LETYP (E) TYPE DU MCHAML A CREER * JER1 (E) LONGUEUR DE LA CHAINE DE CARACTERES * IPMODL (E) POINTEUR DE L'OBJET MODELE * ISUP1 (E) SUPPORT DEMANDE * ICHA (S) POINTEUR SUR LE MCHAML RESULTAT * * LANGAGE: * -------- * * ESOPE + FORTRAN77 * ************************************************************************ * SEGMENT MPTVAL INTEGER IPOS(NS) ,NSOF(NS) INTEGER IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT * SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT * SEGMENT INFO INTEGER INFELL(JG) ENDSEGMENT * PARAMETER ( N3=6 ) PARAMETER (NINF=3) CHARACTER*(*) MONMOT, LETYP CHARACTER*8 CHARIN,chaiii CHARACTER*(NCONCH) CONM CHARACTER*16 typppp CHARACTER*4 CAR,CAR2 DIMENSION INFOS(NINF) C C ACTIVATION DU MODELE C MMODEL=IPMODL SEGACT MMODEL NSOUS=KMODEL(/1) KEL22 = 0 DO I=1,NSOUS IMODEL=KMODEL(I) SEGACT IMODEL*NOMOD IF (NEFMOD.EQ.22) KEL22 = KEL22+1 ENDDO INFOS(1) = 0 INFOS(2) = 0 INFOS(3) = NIFOUR INFO = 0 * * INITIALISATION DU SEGMENT MCHELM * N1 = NSOUS-KEL22 L1=JER1 SEGINI,MCHELM ICHA=MCHELM TITCHE=LETYP IFOCHE=IFOUR * SEGACT,MLMOTS SEGACT,MLMOT3 SEGACT,MLMOT2 N2=MOTS(/2) IF(MONMOT.EQ.'REAL*8 ') THEN MLREEL=IPOI SEGACT,MLREEL ELSE MLENTI=IPOI SEGACT,MLENTI ENDIF * * BOUCLE SUR LES ZONES ELEMENTAIRES DU MODELE * kch=0 DO 20 I=1,NSOUS C C ON RECUPERE L INFORMATION GENERALE C IMODEL=KMODEL(I) C* SEGACT IMODEL*NOMOD IPMAIL=IMAMOD CONM =CONMOD C____________________________________________________________________ C C INFORMATION SUR L'ELEMENT FINI C____________________________________________________________________ C MELE=NEFMOD IF (MELE.EQ.22) GOTO 20 kch=kch+1 * ISUP = ISUP1 IPPORE=0 IF(MELE.GE.79.AND.MELE.LE.83) IPORE=NBNNE(NUMGEO(MELE)) NFOR=FORMOD(/2) CALL PLACE(FORMOD,NFOR,ITHER,'THERMIQUE') CALL PLACE(FORMOD,NFOR,ICONV,'CONVECTION') CALL PLACE(FORMOD,NFOR,IFROT,'FROTTEMENT') CALL PLACE(FORMOD,NFOR,IDARC,'DARCY') C C CAS DE LA FORMULATION DARCY ON VA EXTRAIRE LE MAILLAGE SOMMET IF(IDARC.NE.0)THEN CALL LEKMOD(MMODEL,IPTABL,INEFMD) CHARIN = 'MAILLAGE' CALL LEKTAB(IPTABL,CHARIN, IOBRE) IF (IERR.NE.0) RETURN IPT1 = IOBRE IPMAIL= IOBRE SEGACT MMODEL,IMODEL DO 30 JJ=1,N1 IMODE1=KMODEL(JJ) SEGACT IMODE1 30 CONTINUE IF(N1.GT.1)THEN SEGACT IPT1 IPMAIL= IPT1.LISOUS(I) C SEGDES IPT1 ENDIF ENDIF * * PETIT TEST EN CAS DE FORMULATION FROTTEMENT * LE SEUL SUPPORT = LES NOEUDS * AM 25/1/08 ON FORCE LE SUPPORT EN CONSEQUENCE * AU LIEU DE SORTIR EN ERREUR * IF(IFROT.NE.0.AND.ISUP.NE.1) ISUP = 1 * IPMIN=0 MFR=0 IF(ISUP.NE.1)THEN segact imodel IF(ITHER.EQ.0.AND.ICONV.EQ.0) THEN if( 2+isup.gt.infmod(/1)) then CALL ELQUOI(MELE,0,ISUP,IPINF,IMODEL) IF (IERR.NE.0) GOTO 99 INFO=IPINF IPMIN=INFELL(11) MFR=INFELL(13) else IPMIN=infmod(isup+2) MFR=INFELE(13) endif ELSE IF(ITHER.NE.0)THEN iplr=0 iplc=0 CALL PLACE(formod,nfor,iplr,'RAYONNEMENT') CALL PLACE(formod,nfor,iplc,'CONVECTION') if(iplr+iplc.eq.0) then CALL TSHAPE(MELE,'GAUSS',IPMIN) else NLG=NUMGEO(MELE) CALL TSHAPE(NLG,'GAUSS',IPMIN) endif ELSE NLG=NUMGEO(MELE) CALL TSHAPE(NLG,'GAUSS',IPMIN) ENDIF c en thermique, on veut les points de gauss ad hoc isup = 6 ENDIF ENDIF MINTE=IPMIN IF (IPMIN.NE.0) SEGACT,MINTE IMACHE(kch)=IPMAIL CONCHE(kch)=CONMOD INFCHE(kch,1) = 0 INFCHE(kch,2) = 0 INFCHE(kch,3) = NIFOUR INFCHE(kch,4) = IPMIN INFCHE(kch,5) = 0 INFCHE(kch,6) = ISUP SEGINI,MCHAML ICHAML(kch)=MCHAML * DO 10 IN=1,N2 NOMCHE(IN)=MOTS(IN) IF (MONMOT.EQ.'REAL*8 ') THEN TYPCHE(IN)=MONMOT(1:6) N1PTEL=1 N1EL=1 N2PTEL=0 N2EL=0 ELSE CAR =MLMOT3.MOTS(IN) CAR2=MLMOT2.MOTS(IN) * * TRAITEMENT PARTICULIER POUR LE TYPE 'MCHAML' *--------------- IF (CAR.EQ.'MCHA') THEN IPT = LECT(IN) * * MODIF 02/94 POUR POUTRE A FIBRES * TEST SUR LES MAILLAGES POINTES * MCHEL1=IPT SEGACT MCHEL1 NSOUS=MCHEL1.ICHAML(/1) IDEM=0 DO 294 IFIB=1,NSOUS IF(IPMAIL.EQ.MCHEL1.IMACHE(IFIB)) IDEM=1 294 CONTINUE SEGDES MCHEL1 * IF(IDEM.EQ.0) GO TO 295 * CALL QUESUP(IPMODL,IPT,ISUP,0,IRET,IRET2) MMODEL=IPMODL SEGACT MMODEL DO 100 J=1,N1 IMODE1=KMODEL(J) SEGACT IMODE1 100 CONTINUE IF (IRET.GT.1) THEN * IF(ISUP.GT.1.AND.ISUP.LE.6.AND.INFO.GT.0) * & SEGSUP INFO SEGSUP MCHAML GOTO 99 ENDIF NBROBL=1 NBRFAC=0 SEGINI NOMID MOTAUX=NOMID LESOBL(1)=NOMCHE(IN) NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)=' ' CALL KOMCHA(IPT,IPMAIL,CONM,MOTAUX,MOTYPE, $ 2,INFOS,3,IVAAUX) SEGSUP NOTYPE IF (IERR.NE.0)THEN * IF(ISUP.GT.1.AND.ISUP.LE.6.AND.INFO.GT.0) * & SEGSUP INFO SEGSUP MCHAML GOTO 99 ENDIF IF(IRET.EQ.1)THEN CALL VALCHE(IVAAUX,1,IPMIN,IPPORE) IF(IERR.NE.0)THEN MPTVAL=IVAAUX MELVA1=IVAL(1) SEGDES MELVA1 SEGSUP MPTVAL SEGSUP MCHAML GOTO 99 ENDIF ENDIF MPTVAL=IVAAUX TYPCHE(IN)=TYVAL(1) MELVA1 = IVAL(1) SEGINI,MELVAL=MELVA1 IELVAL(IN) = MELVAL IF(IRET.EQ.1)THEN SEGSUP MELVA1 ELSE SEGDES MELVA1 ENDIF SEGSUP,MPTVAL SEGDES,MELVAL GO TO 10 ENDIF * 295 CONTINUE if(itart.eq.1.and.car(1:4).eq.'LIST' $ .and.car2(1:4).eq.'REEL') then TYPCHE(IN)='REAL*8 ' ipt4=ipmail segact ipt4 n1el=ipt4.num(/2) segdes ipt4 n1ptel=1 N2PTEL=0 N2EL=0 else chaiii='POINTEUR' typppp= chaiii//car//car2 TYPCHE(IN)=typppp if(ITART.EQ.1.AND.car2(1:4).eq.'INT ') then ipt4=ipmail segact ipt4 n2el=ipt4.num(/2) segdes ipt4 N1PTEL=0 N1EL=0 N2PTEL=1 else N1PTEL=0 N1EL=0 N2PTEL=1 N2EL=1 endif endif ENDIF * * INITIALISATION DU SEGMENT MELVAL * SEGINI,MELVAL IELVAL(IN)=MELVAL IF (MONMOT.EQ.'REAL*8 ') THEN VELCHE(N1PTEL,N1EL)=PROG(IN) ELSE if( itart.eq.1.and.car(1:4).eq.'LIST' $ .and.car2(1:4).eq.'REEL') then mlree2= lect(in) segact mlree2 ia=0 do iop=1,n1el ia=ia+1 if(ia.gt.mlree2.prog(/1)) ia=1 velche(n1ptel,iop)= mlree2.prog(ia) enddo segdes mlree2 else if ( itart.eq.1 $ .and.car2(1:4).eq.'INT ') then mlent2= lect(in) segact mlent2 ia = 0 do iop=1,n2el ia=ia+1 if(ia.gt.mlent2.lect(/1)) ia=1 ielche(n2ptel,iop)= mlent2.lect(ia) enddo segdes mlent2 else IELCHE(N2PTEL,N2EL)=LECT(IN) endif ENDIF SEGDES,MELVAL 10 CONTINUE * END DO IF (IPMIN.NE.0) SEGDES,MINTE IF(ISUP.GT.1.AND.ISUP.LE.6.AND.INFO.GT.0) SEGSUP INFO SEGDES,MCHAML 20 CONTINUE * END DO * 99 CONTINUE IF (MONMOT.EQ.'REAL*8 ') THEN SEGDES,MLREEL ELSE SEGDES,MLENTI ENDIF SEGDES,MLMOTS SEGDES,MLMOT3 SEGDES,MLMOT2 * IF(IERR.EQ.0)THEN SEGDES,MCHELM ELSE SEGSUP,MCHELM ENDIF * RETURN END