C FFORME SOURCE CHAT 12/06/07 21:15:19 7389 SUBROUTINE FFORME IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C C SOUS-PROGRAMME ASSOCIE A L'OPERATEUR FFOR C (LECTURE ET VERIFICATION DES DONNEES PUIS AIGUILLAGE) C C__________________________________________________________________ C APPEL : C C 3D CH2 = FFOR MODL1 (ENTI1) (FLOT1) ('SYME' P1 P2 P3) ('NNOR') ; C 2D CH2 = FFOR MODL1 (ENTI1) (FLOT1) ('SYME' P1 P2 ) ('NNOR') ; C CONV CH2 = FFOR MODL1 (ENTI1) 'CVXE' ; C AXIS CH2 = FFOR MODL1 (ENTI1) ('NGAU' ENTI2) ('CVXE') ('NNOR') ; C C C 03/96 : option supplementaire pour tenir compte de l'absorption du C milieu: C 'ABSO' EXTINC ; C pour simplifier la lecture on demande que ce coef. soit negatif C C 09/02: on donne le nombre de points d'integration pour le traitement C des faces proches en AXIS (cf 'NGAU') C__________________________________________________________________ C OPERANDES : C C CH2 'CHAMELEM' FACTEURS DE FORME C MODL1 'MMODEL' STRUCTURE MODELISEE (CONTOUR OU ENVELOPPE) C ENTI1 'ENTIER' DISCRETISATION ANGULAIRE EN 2D-PLAN OU C 3D-CAS GENERAL C FLOT1 'FLOTTANT' FACTEUR DE DECOUPAGE DES ELEMENTS C CVXE 'MOT CLE' MOT CLE POUR LES CAVITES CONVEXES C SYME 'MOT CLE' MOT CLE DEFINISSANT UN AXE OU UN PLAN C DE SYMETRIE C P1,P2,P3 'POINT' POINTS DEFINISSANT L'AXE OU LE PLAN DE C SYMETRIE C NGAU 'MOT CLE' EN AXISYMETRIQUE C ENTI2 'ENTIER' nombre de points d'integration C C ABSO mot-clé pour un milieu absorbant C EXTINC coefficient d'absorption C__________________________________________________________________ C C -INC CCOPTIO -INC SMMODEL -INC SMCHAML C POINTEUR MYMOD.MMODEL C ___________________________________________________________ C Stockage de numeros de points SEGMENT ,LISTEN INTEGER LECT(NBE) ENDSEGMENT POINTEUR IAXE.LISTEN C ___________________________________________________________ C Stockage d'informations concernant le type des éléments SEGMENT ,INFOEL LOGICAL KCOQ(N1),KQUAD(N1) ENDSEGMENT C ___________________________________________________________ C CHARACTER*4 MOTCLE LOGICAL MCVX,MSYM,MGAUS,MABS C C__________________________________________________________________ C MCVX = .FALSE. MSYM = .FALSE. MGAUS = .FALSE. MABS = .FALSE. KNOR = 1 IAXE = 0 EXTINC = -1.D-5 CALL LIROBJ('MMODEL',MYMOD,1,IRETOU) IF (IERR.NE.0) RETURN mchelm=0 call lirobj('MCHAML', mchel1,0,iretou) call reduaf(mchel1,mymod,mchelm,1,iretr,kerre) if( iretr.ne.1) then call erreur (kerre) return endif C C ----------------------------------------------------- C On va vérifier que le TYPE DES ÉLÉMENTS des maillages C sur lequel repose le modèle CONVIENT . C et le type de modèle C SEGACT MYMOD N1 = MYMOD.KMODEL(/1) iy=0 20 iy=iy+1 if( iy.gt.mymod.kmodel(/1)) then call erreur (19) return endif imodel=mymod.kmodel(iy) segact imodel imail= imamod if(formod(1).ne.'THERMIQUE'.or.matmod(2).ne.'RAYONNEMENT' $ . or. matmod(3).ne.'CAVITE') go to 20 nmat=matmod(/2) inatu=inatuu if(imatee.ne.4) go to 20 * pour la valeur de inatu voir subroutine nomate if( inatu.eq.2)then knor=0 elseif(inatu.eq.3) then MSYM = .TRUE. elseif(inatu.eq.4) then MCVX = .TRUE. elseif(inatu.eq.5) then MSYM = .TRUE. MCVX = .TRUE. elseif(inatu.eq.6) then knor=0 MCVX = .TRUE. elseif(inatu.eq.7) then MSYM = .TRUE. knor=0 elseif(inatu.eq.8) then MSYM = .TRUE. MCVX = .TRUE. knor=1 elseif(inatu.ne.1) then write(6,*) ' pb dans fforme' write(6,*) ' inatu ' , inatu call erreur(5) endif ngax=ivamod(1) int=ivamod(2) npax=20 npax=max ( int,npax) SEGINI INFOEL * recherche du coefficient d'absorption * call zpchel(mchelm,1) if( mchelm.ne.0) then segact mchelm do iy=1,imache(/1) write(6,*) imamod,imache(iy),conche(iy),conmod if( imache(iy).eq.imamod.and.conche(iy).eq.conmod) then mchaml=ichaml(iy) segact mchaml do it=1,nomche(/2) if( nomche(it).eq.'CABS' ) THEN melval=ielval(it) segact melval extinc=-velche(1,1) mabs=.true. segdes melval segdes mchaml go to 8 endif enddo segdes mchaml endif enddo 8 continue segdes mchelm endif write(6,*) ' extinc',extinc write(6,*) ' knor mcvx , msym , mgaus mabs' write(6,*) knor,mcvx , msym , mgaus,mabs C DO 10 ITYP=1,N1 C IMODEL = MYMOD.KMODEL(ITYP) SEGACT IMODEL C C la formulation est simple a priori C IF(FORMOD(1).NE.'THERMIQUE'.or.matmod(2).ne.'RAYONNEMENT') THEN CALL ERREUR(21) RETURN ENDIF write(6,*) ' nefmod ' , nefmod C C On va rega Crder quelle est la nature de l'élément IF (IDIM.EQ.3) THEN IF ((NEFMOD.EQ.4).OR.(NEFMOD.EQ.8)) THEN C TRI3 ou QUA4 KQUAD(ITYP)=.FALSE. KCOQ(ITYP) =.FALSE. ELSEIF ((NEFMOD.EQ.27).OR.(NEFMOD.EQ.49)) THEN C COQ3 ou COQ4 KQUAD(ITYP)=.FALSE. KCOQ(ITYP) =.TRUE. ELSEIF ((NEFMOD.EQ.6).OR.(NEFMOD.EQ.10)) THEN C TRI6 ou QUA8 KQUAD(ITYP)=.TRUE. KCOQ(ITYP) =.FALSE. ELSEIF ((NEFMOD.EQ.56).OR.(NEFMOD.EQ.41)) THEN C COQ6 ou COQ8 KQUAD(ITYP)=.TRUE. KCOQ(ITYP) =.TRUE. ELSE CALL ERREUR(16) RETURN ENDIF C ELSEIF (IDIM.EQ.2) THEN C IF (NEFMOD.EQ.2) THEN C SEG2 KQUAD(ITYP)=.FALSE. KCOQ(ITYP) =.FALSE. ELSEIF (NEFMOD.EQ.44) THEN C COQ2 KQUAD(ITYP)=.FALSE. KCOQ(ITYP) =.TRUE. ELSEIF (NEFMOD.EQ.3) THEN C SEG3 KQUAD(ITYP)=.TRUE. KCOQ(ITYP) =.FALSE. ELSE CALL ERREUR(16) RETURN ENDIF C ELSE CALL ERREUR(14) RETURN ENDIF SEGDES IMODEL 10 CONTINUE SEGDES INFOEL SEGDES MYMOD C C C ---------------------------------------------------- C Orientation vers les différents sous-programmes C IF (IFOMOD.NE.0) THEN C On n'est pas en mode axisymétrique C IF (MCVX.AND.(.NOT.MSYM)) THEN C on n'a recu que CVXE GOTO 100 ELSEIF (MSYM) THEN C il faut lire des points pour le cas général GOTO 200 ELSE C cas général GOTO 210 ENDIF C ELSE C On est en mode axisymétrique GOTO 300 C ENDIF C C********************************************************** C C C C******************** C CAS CONVEXE C******************** C 100 CALL LIRENT(INT1,0,IRETOU) IF (IRETOU.NE.0) THEN INT=INT1 ELSE INT=3 ENDIF write(6,*) ' int ', int CALL FACCVX(MYMOD,INFOEL,INT,ICHFAC) GOTO 900 C C C******************** C CAS GENERAL C******************** C C----cas avec 'SYME' => lecture des points C 200 segact imodel ip1 = ivamod(3) ip2 = ivamod(4) NBE = IDIM SEGINI ,IAXE IAXE.LECT(1) = IP1 IAXE.LECT(2) = IP2 IF (IDIM.EQ.3) THEN ip3=ivamod(5) iaxe.lect(3)=ip3 ENDIF SEGDES IAXE,imodel C C----suite du cas général C 210 CALL LIRENT(INT1,0,IRETOU) IF (IRETOU.NE.0) THEN IF(IDIM.EQ.3) THEN LRES=MIN0(INT1,100) ELSE LRES=MIN0(INT1,1000) ENDIF ELSE IF(IDIM.EQ.3) THEN LRES=50 ELSE LRES=200 ENDIF ENDIF write(6,*) ' lres ' , lres * IF (MABS) THEN * CALL LIRREE(FLO2,0,IRETO2) * CALL LIRREE(FLO1,0,IRETOU) * IF(FLO2.LT.(-1.D-5)) THEN * EXTINC = -FLO2 * ELSE * EXTINC = -FLO1 * FLO1 = FLO2 * IRETOU=IRETO2 * ENDIF * ELSE * CALL LIRREE(FLO1,0,IRETOU) * ENDIF IF (IRETOU.NE.0) THEN IF(IDIM.EQ.3) THEN XDEC=DMIN1(FLO1,2.D0) ELSE XDEC=DMIN1(FLO1,10.D0) ENDIF ELSE IF(IDIM.EQ.3) THEN XDEC=0.5 ELSE XDEC=5.D0 ENDIF ENDIF write(6,*) ' xdec ' , xdec C C IF (IDIM.EQ.3) THEN write(6,*) ' appel a facgen' write(6,*) LRES,XDEC,IAXE,KNOR,EXTINC CALL FACGEN(MYMOD,INFOEL,LRES,XDEC,IAXE,KNOR,ICHFAC,EXTINC) ELSE write(6,*) ' appel a facge2' write(6,*) LRES,XDEC,IAXE,KNOR,EXTINC write(6,*) ( kcoq(iou),kquad(iou),iou=1,kcoq(/1)) CALL FACGE2(MYMOD,INFOEL,LRES,XDEC,IAXE,KNOR,ICHFAC,EXTINC) ENDIF IF (IAXE.NE.0) SEGSUP IAXE C GOTO 900 C C******************** C CAS AXISYMETRIQUE C******************** C 300 CONTINUE C valeurs par defaut NGAX=10 NPAX=20 CALL LIRENT(INT1,0,IRETO1) CALL LIRENT(INT2,0,IRETO2) IF (IRETO2.NE.0) THEN NGAX = MIN0(INT1,10) NPAX = MIN0(INT2,1000) ELSEIF (MGAUS) THEN NPAX = MIN0(INT1,1000) ELSEIF (IRETO1.NE.0) THEN NGAX=MIN0(INT1,10) ENDIF C WRITE(6,*) ' FFOR NG NP ',NGAX,NPAX IF (MCVX) THEN KACHE = 0 ELSE KACHE = 1 ENDIF C IF(MABS) THEN CALL LIRREE(FLO1,0,IRETOU) IF (IRETOU.NE.0) THEN EXTINC=-FLO1 ENDIF ENDIF CALL FACAXI(MYMOD,INFOEL,NPAX,NGAX,KACHE,KNOR,ICHFAC,EXTINC) C C C********************************************************** C C 900 SEGSUP ,INFOEL segact mymod mchelm=ICHFAC segact mchelm*mod do i=1,mymod.kmodel(/1) imodel=mymod.kmodel(i) segact imodel conche(i)=conmod segdes imodel enddo segdes mchelm segdes mymod C Ecriture du chamelem facteur de forme CALL ECROBJ('MCHAML',ICHFAC) RETURN END