C++++++ DEBUT FIGURE 6.10 C MEF 1 C=======================================================================MEF 2 C MEF 3 C PROGRAMME M . E . F . - 3 - VERSION 'LIVRE' OCTOBRE 1979 MEF 4 C ( G.TOUZOT , G.DHATT ) MEF 5 C PROGRAMME PRINCIPAL MEF 6 C MEF 7 C=======================================================================MEF 8 IMPLICIT REAL*8(A-H,O-Z) MEF 9 REAL*4 BLOC,BLOCS MEF 10 COMMON/ALLOC/NVA,IVA,IVAMAX,NREEL,NTBL MEF 11 COMMON/ES/M,MR,MP,MLUN(10) MEF 12 COMMON VA(20000) MEF 13 DIMENSION BLOCS(21) MEF 14 DATA BLOCS/4HIMAG,4HCOMT,4HCOOR,4HDLPN,4HCOND,4HPRND,4HPREL, MEF 15 1 4HELEM,4HSOLC,4HSOLR,4HLINM,4HLIND,4HNLIN,4HTEMP, MEF 16 2 4HVALP,4H....,4H....,4H....,4H....,4H....,4HSTOP/ MEF 17 DATA NB/21/ MEF 18 C-----------------------------------------------------------------------MEF 19 C....... DIMENSION DU COMMON BLANC EN MOTS REELS (TABLE VA) MEF 20 NVA=20000 MEF 21 OPEN(5,file='MEF.INP',type='OLD') OPEN(6,file='MEF.OUT',type='UNKNOWN') C------- EN-TETE MEF 22 WRITE(MP,2000) MEF 23 2000 FORMAT(1H1,30X,'M.E.F.3.'/23X,' G.TOUZOT , G.DHATT'/23X,22('-')//)MEF 24 C------- LECTURE DE L'EN-TETE D'UN BLOC MEF 25 10 READ(MR,1000) BLOC,M,MLUN MEF 26 1000 FORMAT(A4,I6,10I5) MEF 27 C------- RECHERCHE DU BLOC A EXECUTER MEF 28 DO 20 I=1,NB MEF 29 IF(BLOC.EQ.BLOCS(I)) GO TO 30 MEF 30 20 CONTINUE MEF 31 WRITE(MP,2010) MEF 32 2010 FORMAT(' ** ERREUR, CARTE D APPEL DE BLOC MANQUANTE') MEF 33 GO TO 10 MEF 34 30 GO TO (110,120,130,140,150,160,170, MEF 35 1 180,190,200,210,220,230,240, MEF 36 2 250,260,270,280,290,300,999),I MEF 37 C------- BLOC D'IMPRESSION DE L'ENSEMBLE DES DONNEES 'IMAG' MEF 38 110 CALL BLIMAG MEF 39 GO TO 10 MEF 40 C------- BLOC DE LECTURE-IMPRESSION DE COMMENTAIRES 'COMT' MEF 41 120 CALL BLCOMT MEF 42 GO TO 10 MEF 43 C------- BLOC DE LECTURE DES NOEUDS 'COOR' MEF 44 130 CALL BLCOOR MEF 45 GO TO 10 MEF 46 C------- BLOC DE LECTURE DES DEGRES DE LIBERTE PAR NOEUD 'DLPN' MEF 47 140 CALL BLDLPN MEF 48 GO TO 10 MEF 49 C------- BLOC DE LECTURE DES CONDITIONS AUX LIMITES 'COND' MEF 50 150 CALL BLCOND MEF 51 GO TO 10 MEF 52 C------- BLOC DE LECTURE DES PROPRIETES NODALES 'PRND' MEF 53 160 CALL BLPRND MEF 54 GO TO 10 MEF 55 C------- BLOC DE LECTURE DES PROPRIETES ELEMENTAIRES 'PREL' MEF 56 170 CALL BLPREL MEF 57 GO TO 10 MEF 58 C------- BLOC DE LECTURE DES ELEMENTS 'ELEM' MEF 59 180 CALL BLELEM MEF 60 GO TO 10 MEF 61 C------- BLOC DE LECTURE DES SOLLICITATIONS CONCENTREES 'SOLC' MEF 62 190 CALL BLSOLC MEF 63 GO TO 10 MEF 64 C------- BLOC DE LECTURE DES SOLLICITATIONS REPARTIES 'SOLR' MEF 65 200 CALL BLSOLR MEF 66 GO TO 10 MEF 67 C------- BLOC D'ASSEMBLAGE-RESOLUTION LINEAIRE EN MEMOIRE 'LINM' MEF 68 210 CALL BLLINM MEF 69 GO TO 10 MEF 70 C------- BLOC ASSEMBLAGE-RESOLUTION LINEAIRE SUR DISQUE 'LIND' MEF 71 220 CALL BLLIND MEF 72 GO TO 10 MEF 73 C------- BLOC DE RESOLUTION NON LINEAIRE 'NLIN' MEF 74 230 CALL BLNLIN MEF 75 GO TO 10 MEF 76 C------- BLOC DE RESOLUTION NON STATIONNAIRE 'TEMP' MEF 77 240 CALL BLTEMP MEF 78 GO TO 10 MEF 79 C------- BLOC DE CALCUL DE VALEURS PROPRES (SOUS ESPACE) 'VALP' MEF 80 250 CALL BLVALP MEF 81 GO TO 10 MEF 82 C------- BLOCS NON DEFINIS MEF 83 260 CONTINUE MEF 84 270 CONTINUE MEF 85 280 CONTINUE MEF 86 290 CONTINUE MEF 87 300 CONTINUE MEF 88 GO TO 10 MEF 89 C------- FIN DU PROBLEME 'STOP' MEF 90 999 WRITE(MP,2020) IVAMAX,NVA MEF 91 2020 FORMAT(//' FIN DU PROBLEME, ',I10,' MOTS REELS UTILISES SUR ',I10)MEF 92 STOP MEF 93 END MEF 94 BLOCK DATA BLOC 1 C=======================================================================BLOC 2 C INITIALISATION DES COMMONS ETIQUETES BLOC 3 C=======================================================================BLOC 4 IMPLICIT REAL*8(A-H,O-Z) BLOC 5 COMMON/COOR/NDIM,NNT,NDLN,NDLT,FAC(3) BLOC 6 COMMON/COND/NCLT,NCLZ,NCLNZ BLOC 7 COMMON/PRND/NPRN BLOC 8 COMMON/PREL/NGPE,NPRE BLOC 9 COMMON/ELEM/NELT,NNEL,NTPE,NGRE,ME,NIDENT,NPG BLOC 10 COMMON/ASSE/NSYM,NKG,NKE,NDLE BLOC 11 COMMON/RESO/NEQ,NRES,MRES BLOC 12 COMMON/RGDT/IEL,ITPE,ITPE1,IGRE,IDLE,ICE,IPRNE,IPREE,INEL,IDEG, BLOC 13 1 IPG,ICOD,IDLE0,INEL0,IPG0 BLOC 14 COMMON/LIND/NLBL,NBLM,MKG1,MKG2 BLOC 15 COMMON/NLIN/EPSDL,XNORM,OMEGA,XPAS,DPAS,DPAS0,NPAS,IPAS,NITER, BLOC 16 1 ITER,IMETH BLOC 17 COMMON/VALP/NITER1,NMDIAG,EPSLB,SHIFT,NSS,NSWM,TOLJAC,NVALP BLOC 18 COMMON/ES/M,MR,MP,MLUN(10) BLOC 19 COMMON/ALLOC/NVA,IVA,IVAMAX,NREEL,NTBL BLOC 20 COMMON/LOC/LCORG,LDLNC,LNEQ,LDIMP,LPRNG,LPREG,LLD,LLOCE,LCORE,LNE,BLOC 21 1 LPRNE,LPREE,LDLE,LKE,LFE,LKGS,LKGD,LKGI,LFG,LRES,LDLG,LME, BLOC 22 2 LDLE0,LDLG0,LFG0 BLOC 23 DIMENSION LXX(25) BLOC 24 EQUIVALENCE (LXX(1),LCORG) BLOC 25 C------- COMMON /COOR/ BLOC 26 DATA NNT/20/,NDLN/2/,NDIM/2/,FAC/3*1.D0/ BLOC 27 C------- COMMON /PRND/ BLOC 28 DATA NPRN/0/ BLOC 29 C------- COMMON /PREL/ BLOC 30 DATA NGPE/0/,NPRE/0/ BLOC 31 C------- COMMON /ELEM/ BLOC 32 DATA NELT/20/,NNEL/8/,NTPE/1/,NGRE/1/,ME/1/,NIDENT/0/ BLOC 33 C------- COMMON/ASSE/ BLOC 34 DATA NSYM/0/ BLOC 35 C------- COMMON /RESO/ BLOC 36 DATA NRES/0/,MRES/2/ BLOC 37 C------- COMMON /RGDT/ BLOC 38 DATA ITPE1/0/ BLOC 39 C------- COMMON /LIND/ BLOC 40 DATA MKG1/4/,MKG2/7/ BLOC 41 C------- COMMON /NLIN/ BLOC 42 DATA EPSDL/1.D-2/,OMEGA/1.D0/,DPAS/.2D0/,NPAS/1/,NITER/5/,IMETH/1/BLOC 43 C------- COMMON /VALP/ BLOC 44 DATA NITER1/10/,NMDIAG/0/,EPSLB/1.D-3/,SHIFT/0.D0/,NSS/5/, BLOC 45 1 NSWM/12/,TOLJAC/1.D-12/,NVALP/3/ BLOC 46 C------- COMMON /ES/ BLOC 47 DATA MR/5/,MP/6/ BLOC 48 C------- COMMON /ALLOC/ BLOC 49 DATA IVA/1/,IVAMAX/1/,NTBL/25/ BLOC 50 C....... DEFINIR ICI LE NOMBRE D'ENTIERS CONTENUS DANS UN REEL BLOC 51 C SUR LE CALCULATEUR UTILISE BLOC 52 C EXEMPLES: IBM SIMPLE PRECISION NREEL.EQ.1 BLOC 53 C IBM DOUBLE PRECISION NREEL.EQ.2 BLOC 54 C CDC NREEL.EQ.1 BLOC 55 DATA NREEL/2/ BLOC 56 C....... BLOC 57 C------- COMMON /LOC/ BLOC 58 DATA LXX/25*1/ BLOC 59 END BLOC 60 SUBROUTINE ERREUR(IERR,I1,I2,INIV) ERRE 1 C=======================================================================ERRE 2 C IMPRESSION DES ERREURS DANS LES BLOCS DE LECTURE DES DONNEES ERRE 3 C=======================================================================ERRE 4 COMMON/ES/M,MR,MP ERRE 5 C-----------------------------------------------------------------------ERRE 6 C------- BLOC 'COOR' ERRE 7 IF(IERR.GT.19) GO TO 200 ERRE 8 IE=IERR-10 ERRE 9 GO TO (110,120,130,140,150,160,160,180),IE ERRE 10 110 WRITE(MP,2110)I1,I2 ERRE 11 2110 FORMAT(' *** ERREUR, LE NUMERO DU PREMIER NOEUD(',I4,') EST SUPERIERRE 12 1EUR A NNT=',I4) ERRE 13 GO TO 900 ERRE 14 120 WRITE(MP,2120)I1,I2 ERRE 15 2120 FORMAT(' ** ERREUR, LE NUMERO DU SECOND NOEUD(',I4,') EST SUPERIEUERRE 16 1R A NNT=',I4) ERRE 17 GO TO 900 ERRE 18 130 WRITE(MP,2130)I1,I2 ERRE 19 2130 FORMAT(' ** ERREUR, LE NOMBRE DE D.L. DU NOEUD(',I4,') EST SUPERIEERRE 20 1UR A NDLN=',I4) ERRE 21 GO TO 900 ERRE 22 140 WRITE(MP,2140) ERRE 23 2140 FORMAT(' ** ERREUR, LES NUMEROS DU PREMIER ET DU SECOND NOEUDS SONERRE 24 1T INCOMPATIBLES AVEC L INCREMENT DE GENERATION') ERRE 25 GO TO 900 ERRE 26 150 WRITE(MP,2150)I1 ERRE 27 2150 FORMAT(' ** ERREUR, LE NOEUD ',I4,' EST DEFINI PLUSIEURS FOIS') ERRE 28 GO TO 900 ERRE 29 160 WRITE(MP,2160)I1 ERRE 30 2160 FORMAT(' ** ERREUR, LE NOEUD ',I4,' N EST PAS DEFINI') ERRE 31 GO TO 900 ERRE 32 180 WRITE(MP,2180)I2,I1 ERRE 33 2180 FORMAT(' ** ERREUR, LE NOMBRE DE NOEUDS CREES(',I4,') EST INFERIEUERRE 34 1R A NNT=',I4) ERRE 35 GO TO 900 ERRE 36 C------- BLOC 'DLPN' ERRE 37 200 IF(IERR.GT.29) GO TO 300 ERRE 38 IE=IERR-20 ERRE 39 GO TO (210,220),IE ERRE 40 210 WRITE(MP,2210)I1,I2 ERRE 41 2210 FORMAT(' ** ERREUR, LE NOMBRE DE D.L. (',I2,') EST SUPERIEUR A NDLERRE 42 1N=',I2) ERRE 43 GO TO 900 ERRE 44 220 WRITE(MP,2220)I1,I2 ERRE 45 2220 FORMAT(' ** ERREUR, LE NUMERO D UN NOEUD(',I4,') EST SUPERIEUR A NERRE 46 1NT=',I4) ERRE 47 GO TO 900 ERRE 48 C------- BLOC 'COND' ERRE 49 300 IF(IERR.GT.39)GO TO 400 ERRE 50 IE=IERR-30 ERRE 51 GO TO (900,320,900),IE ERRE 52 320 GO TO 220 ERRE 53 C------- BLOC 'PREL' ERRE 54 400 IF(IERR.GT.49) GO TO 500 ERRE 55 IE=IERR-40 ERRE 56 GO TO (410,900),IE ERRE 57 410 WRITE(MP,2410)I1,I2 ERRE 58 2410 FORMAT(' ** ERREUR, LE NUMERO DE GROUPE (',I3,') EST SUPERIEUR A NERRE 59 1GPE=',I3) ERRE 60 GO TO 900 ERRE 61 C------- BLOC 'ELEM' ERRE 62 500 IF(IERR.GT.59) GO TO 900 ERRE 63 IE=IERR-50 ERRE 64 GO TO (510,900,530,540,550,560,570),IE ERRE 65 510 WRITE(MP,2510)I1,I2 ERRE 66 2510 FORMAT(' ** ERREUR, LE NOMBRE DE NOEUDS(',I3,') EST SUPERIEUR A NNERRE 67 1EL=',I3) ERRE 68 GO TO 900 ERRE 69 530 WRITE(MP,2530)I1,I2 ERRE 70 2530 FORMAT(' ** ERREUR, NUMERO DE PROPRIETE (',I3,') SUPERIEUR A NGPE=ERRE 71 1',I3) ERRE 72 GO TO 900 ERRE 73 540 WRITE(MP,2540)I1,I2 ERRE 74 2540 FORMAT(' ** ERREUR, NUMERO DE GROUPE (',I3,') SUPERIEUR A NGRE=', ERRE 75 1I3) ERRE 76 GO TO 900 ERRE 77 550 WRITE(MP,2550)I1,I2 ERRE 78 2550 FORMAT(' ** ERREUR, NUMERO D ELEMENT (',I4,') SUPERIEUR A NELT=', ERRE 79 1I4) ERRE 80 GO TO 900 ERRE 81 560 GO TO 220 ERRE 82 570 WRITE(MP,2570)I1,I2 ERRE 83 2570 FORMAT(' ** ERREUR, NOMBRE D ELEMENTS (',I4,') SUPERIEUR A NELT=',ERRE 84 1I4) ERRE 85 C------- FIN ERRE 86 900 I1=I2 ERRE 87 IF(INIV.GE.2) STOP ERRE 88 RETURN ERRE 89 END ERRE 90 C++++++ FIN FIGURE 6.10 C++++++ DEBUT FIGURE 6.5 SUBROUTINE ESPACE(ILONG,IREEL,TBL,IDEB) ESPA 1 C=======================================================================ESPA 2 C ALLOCATION D'UNE TABLE REELLE OU ENTIERE DANS LA TABLE VA ESPA 3 C ENTREES ESPA 4 C ILONG LONGUEUR DE LA TABLE A CREER ESPA 5 C (EN MOTS REELS OU ENTIERS) ESPA 6 C IREEL TYPE DE LA TABLE : ESPA 7 C .EQ.0 ENTIERE ESPA 8 C .EQ.1 REELLE ESPA 9 C TBL NOM DE LA TABLE (A4) ESPA 10 C SORTIE ESPA 11 C IDEB LA TABLE CREEE DEBUTE EN VA(IDEB) ESPA 12 C=======================================================================ESPA 13 IMPLICIT REAL*8(A-H,O-Z) ESPA 14 REAL*4 TBL ESPA 15 COMMON/ES/M,MR,MP ESPA 16 COMMON/ALLOC/NVA,IVA,IVAMAX,NREEL ESPA 17 COMMON VA(1) ESPA 18 DIMENSION KA(1) ESPA 19 EQUIVALENCE (VA(1),KA(1)) ESPA 20 DATA ZERO/0.D0/ ESPA 21 C-----------------------------------------------------------------------ESPA 22 C------- CALCULER LA LONGUEUR DE LA TABLE EN MOTS REELS ESPA 23 ILGR=ILONG ESPA 24 IF(IREEL.EQ.0) ILGR=(ILONG+NREEL-1)/NREEL ESPA 25 IVA1=IVA+ILGR ESPA 26 C------- VERIFIER SI L'ESPACE EST DISPONIBLE ESPA 27 IF(IVA1.LE.NVA) GO TO 20 ESPA 28 C....... EXTENSION AUTOMATIQUE DU COMMON BLANC SI LA COMMANDE ESPA 29 C SYSTEME CORRESPONDANTE EXISTE SUR LE CALCULATEUR UTILISE ESPA 30 C CALL EXTEND(IVA1,IERR) ESPA 31 C IF(IERR.EQ.1) GO TO 10 ESPA 32 C NVA=IVA1 ESPA 33 C GO TO 20 ESPA 34 C------- ERREUR D'ALLOCATION (MANQUE D'ESPACE) ESPA 35 10 WRITE(MP,2000) TBL,IVA1,NVA ESPA 36 2000 FORMAT(' **** ERREUR D ALLOCATION, TABLE ',A4/' ESPACE REQUIS:',I9ESPA 37 1,' MOTS REELS, ESPACE DISPONIBLE:',I9,' MOTS REELS') ESPA 38 STOP ESPA 39 C------- ALLOCATION DE LA TABLE ESPA 40 20 IDEB=IVA+1 ESPA 41 IVA=IVA1 ESPA 42 IF(IVA.GT.IVAMAX) IVAMAX=IVA ESPA 43 IF(M.GT.0) WRITE(MP,2010) TBL,IDEB,IVA1 ESPA 44 2010 FORMAT(60X,'TABLE ',A4,' PLACEE DE VA(',I7,') A VA(',I7,')') ESPA 45 C------- INITIALISATION A ZERO DE LA TABLE CREEE ESPA 46 I1=IDEB ESPA 47 IF(IREEL.EQ.0) I1=(I1-1)*NREEL+1 ESPA 48 I2=I1+ILONG-1 ESPA 49 IF(IREEL.EQ.0) GO TO 40 ESPA 50 DO 30 I=I1,I2 ESPA 51 30 VA(I)=ZERO ESPA 52 RETURN ESPA 53 40 DO 50 I=I1,I2 ESPA 54 50 KA(I)=0 ESPA 55 RETURN ESPA 56 END ESPA 57 SUBROUTINE VIDE(IDEB,IREEL,TBL) VIDE 1 C=======================================================================VIDE 2 C SUPPRESSION D'UNE TABLE SITUEE DANS VA, AVEC COMPACTAGE VIDE 3 C ENTREE VIDE 4 C IDEB POSITION DU DEBUT DE LA TABLE A DETRUIRE VIDE 5 C IREEL TYPE DE LA TABLE (VOIR ESPACE) VIDE 6 C TBL NOM DE LA TABLE (A4) VIDE 7 C=======================================================================VIDE 8 IMPLICIT REAL*8(A-H,O-Z) VIDE 9 REAL*4 TBL VIDE 10 COMMON/ES/M,MR,MP VIDE 11 COMMON/ALLOC/NVA,IVA,IVAMAX,NREEL,NTBL VIDE 12 COMMON/LOC/LXX(25) VIDE 13 COMMON VA(1) VIDE 14 C-----------------------------------------------------------------------VIDE 15 C------- RECHERCHE DU DEBUT DE LA TABLE SUIVANTE VIDE 16 I1=IVA+1 VIDE 17 DO 10 I=1,NTBL VIDE 18 IF(LXX(I).LE.IDEB) GO TO 10 VIDE 19 IF(LXX(I).LT.I1) I1=LXX(I) VIDE 20 10 CONTINUE VIDE 21 C------- DECALAGE DES TABLES SUIVANTES VIDE 22 ID=I1-IDEB VIDE 23 IF(I1.EQ.IVA+1) GO TO 40 VIDE 24 DO 20 I=1,NTBL VIDE 25 IF(LXX(I).GT.IDEB) LXX(I)=LXX(I)-ID VIDE 26 20 CONTINUE VIDE 27 DO 30 I=I1,IVA VIDE 28 J=I-ID VIDE 29 30 VA(J)=VA(I) VIDE 30 C------- IMPRESSION VIDE 31 40 IVA=IVA-ID VIDE 32 IF(M.GT.0) WRITE(MP,2000) TBL,ID,IDEB VIDE 33 2000 FORMAT(60X,'SUPPRESSION TABLE ',A4,' COMPACTAGE ',I7,' MOTS REELS VIDE 34 1APRES VA(',I7,')') VIDE 35 RETURN VIDE 36 END VIDE 37 C++++++ FIN FIGURE 6.5 C++++++ DEBUT FIGURE 6.11 SUBROUTINE BLIMAG BLIM 1 C=======================================================================BLIM 2 C APPEL ET EXECUTION DU BLOC 'IMAG' BLIM 3 C IMPRESSION DE L'ENSEMBLE DES CARTES DE DONNEES BLIM 4 C=======================================================================BLIM 5 IMPLICIT REAL*8(A-H,O-Z) BLIM 6 COMMON/ES/M,MR,MP,M1 BLIM 7 COMMON/TRVL/CART(20) BLIM 8 DATA ICARTM/40/ BLIM 9 C-----------------------------------------------------------------------BLIM 10 IF(M1.EQ.0) M1=MR BLIM 11 WRITE(MP,2000) BLIM 12 2000 FORMAT(///,1X,'IMAGE DES DONNEES SUR CARTES'/1X,28('='),/) BLIM 13 WRITE(MP,2005) BLIM 14 2005 FORMAT(/ BLIM 15 1 50X,'N U M E R O D E C O L O N N E',/,13X,'NUMERO',6X, BLIM 16 2 10X,'1',9X,'2',9X,'3',9X,'4',9X,'5',9X,'6',9X,'7',9X,'8',/, BLIM 17 3 12X,'DE CARTE',6X,8('1234567890'),/,12X,8('-'),6X,80('-')) BLIM 18 ICART=0 BLIM 19 ICART1=0 BLIM 20 10 READ(M1,1000,END=30) CART BLIM 21 1000 FORMAT(20A4) BLIM 22 ICART=ICART+1 BLIM 23 ICART1=ICART1+1 BLIM 24 IF(ICART1.LE.ICARTM) GO TO 20 BLIM 25 WRITE(MP,2010) BLIM 26 2010 FORMAT(12X,8(1H-),6X,80(1H-),/,13X,'NUMERO',7X,8('1234567890'),/, BLIM 27 1 12X,'DE CARTE',6X,9X,'1',9X,'2',9X,'3',9X,'4',9X,'5',9X,'6', BLIM 28 2 9X,'7',9X,'8',/,50X,'N U M E R O D E C O L O N N E') BLIM 29 WRITE(MP,2015) BLIM 30 2015 FORMAT(1H1,//) BLIM 31 WRITE(MP,2005) BLIM 32 ICART1=0 BLIM 33 20 WRITE(MP,2020) ICART,CART BLIM 34 2020 FORMAT(10X,I10,6X,20A4) BLIM 35 GO TO 10 BLIM 36 30 WRITE(MP,2010) BLIM 37 WRITE(MP,2030) BLIM 38 2030 FORMAT(///,51X,'F I N D E S D O N N E E S',/,1H1) BLIM 39 REWIND M1 BLIM 40 READ(M1,1000) CART BLIM 41 RETURN BLIM 42 END BLIM 43 C++++++ FIN FIGURE 6.11 C++++++ DEBUT FIGURE 6.12 SUBROUTINE BLCOMT BLCM 1 C=======================================================================BLCM 2 C APPEL ET EXECUTION DU BLOC 'COMT' BLCM 3 C=======================================================================BLCM 4 IMPLICIT REAL*8(A-H,O-Z) BLCM 5 REAL*4 BLANC,CART BLCM 6 COMMON/ES/M,MR,MP BLCM 7 COMMON/TRVL/CART(20) BLCM 8 DATA BLANC/4H / BLCM 9 C-----------------------------------------------------------------------BLCM 10 WRITE(MP,2000) BLCM 11 2000 FORMAT(//' COMMENTAIRES'/' ',13('=')/) BLCM 12 C------- LECTURE D'UNE CARTE DE COMMENTAIRE BLCM 13 10 READ(MR,1000) CART BLCM 14 1000 FORMAT(20A4) BLCM 15 C------- RECHERCHE D'UNE CARTE ENTIEREMENT BLANCHE BLCM 16 DO 20 I=1,20 BLCM 17 IF(CART(I).NE.BLANC) GO TO 30 BLCM 18 20 CONTINUE BLCM 19 RETURN BLCM 20 30 WRITE(MP,2010) CART BLCM 21 2010 FORMAT(1X,20A4) BLCM 22 GO TO 10 BLCM 23 END BLCM 24 C++++++ FIN FIGURE 6.12 C++++++ DEBUT FIGURE 6.13 SUBROUTINE BLCOOR BLCR 1 C=======================================================================BLCR 2 C APPEL DU BLOC 'COOR' BLCR 3 C LECTURE DES COORDONNEES DES NOEUDS BLCR 4 C=======================================================================BLCR 5 IMPLICIT REAL*8(A-H,O-Z) BLCR 6 REAL*4 TBL BLCR 7 COMMON/COOR/NDIM,NNT,NDLN,NDLT,FAC(3) BLCR 8 COMMON/ES/M,MR,MP,M1 BLCR 9 COMMON/ALLOC/NVA BLCR 10 COMMON/LOC/LCORG,LDLNC BLCR 11 COMMON/TRVL/FAC1(3),IN(3) BLCR 12 COMMON VA(1) BLCR 13 DIMENSION TBL(2) BLCR 14 DATA ZERO/0.D0/,TBL/4HCORG,4HDLNC/ BLCR 15 C-----------------------------------------------------------------------BLCR 16 C------- EN-TETE DE BLOC BLCR 17 IF(M1.EQ.0) M1=MR BLCR 18 READ(M1,1000) IN,FAC1 BLCR 19 1000 FORMAT(3I5,3F10.0) BLCR 20 C------- OPTIONS PAR DEFAUT BLCR 21 IF(IN(1).GT.0) NNT=IN(1) BLCR 22 IF(IN(2).GT.0) NDLN=IN(2) BLCR 23 IF(IN(3).GT.0) NDIM=IN(3) BLCR 24 DO 10 I=1,3 BLCR 25 IF(FAC1(I).NE.ZERO) FAC(I)=FAC1(I) BLCR 26 10 CONTINUE BLCR 27 C------- IMPRESSION DES PARAMETRES DU BLOC BLCR 28 WRITE(MP,2000) M,NNT,NDLN,NDIM,FAC,NVA BLCR 29 2000 FORMAT(//' LECTURE DES NOEUDS (M=',I2,')'/' ',18('=')/ BLCR 30 1 15X,'NOMBRE MAX. DE NOEUDS (NNT)=',I5/ BLCR 31 2 15X,'NOMBRE MAX. DE D.L. PAR NOEUD (NDLN)=',I5/ BLCR 32 3 15X,'NOMBRE DE DIMENSIONS DU PROBLEME (NDIM)=',I5/ BLCR 33 4 15X,'FACTEUR D ECHELLE DES COORDONNEES (FAC)=',3E12.5/ BLCR 34 5 15X,'ESPACE DE TRAVAIL EN MOTS REELS (NVA)=',I10) BLCR 35 C------- ALLOCATION D'ESPACE BLCR 36 IF(LCORG.EQ.1) CALL ESPACE(NNT*NDIM,1,TBL(1),LCORG) BLCR 37 IF(LDLNC.EQ.1) CALL ESPACE(NNT+1,0,TBL(2),LDLNC) BLCR 38 C------- EXECUTION DU BLOC BLCR 39 CALL EXCOOR(VA(LCORG),VA(LDLNC)) BLCR 40 RETURN BLCR 41 END BLCR 42 SUBROUTINE EXCOOR(VCORG,KDLNC) EXCR 1 C=======================================================================EXCR 2 C EXECUTION DU BLOC 'COOR' EXCR 3 C LECTURE DES COORDONNEES DES NOEUDS EXCR 4 C=======================================================================EXCR 5 IMPLICIT REAL*8(A-H,O-Z) EXCR 6 COMMON/COOR/NDIM,NNT,NDLN,NDLT,FAC(3) EXCR 7 COMMON/ES/M,MR,MP,M1 EXCR 8 COMMON/TRVL/X1(3),X2(3) EXCR 9 DIMENSION VCORG(1),KDLNC(1) EXCR 10 DATA SPECL/1.23456789D31/ EXCR 11 C-----------------------------------------------------------------------EXCR 12 C------- INITIALISATION DES COORDONNEES EXCR 13 I1=(NNT-1)*NDIM+1 EXCR 14 DO 10 I=1,I1,NDIM EXCR 15 10 VCORG(I)=SPECL EXCR 16 C------- LECTURE DES CARTES DE NOEUDS EXCR 17 IF(M.GT.0) WRITE(MP,2000) EXCR 18 2000 FORMAT(//' CARTES DE NOEUDS'/) EXCR 19 20 READ(M1,1000) IN1,X1,IN2,X2,INCR,IDLN EXCR 20 1000 FORMAT(2(I5,3F10.0),2I5) EXCR 21 IF(M.GT.0) WRITE(MP,2010) IN1,X1,IN2,X2,INCR,IDLN EXCR 22 2010 FORMAT(' >>>>>',2(I5,3E12.5),2I5) EXCR 23 IF(IN1.LE.0) GO TO 60 EXCR 24 C------- DECODAGE DE LA CARTE EXCR 25 IF(IN1.GT.NNT) CALL ERREUR(11,IN1,NNT,0) EXCR 26 IF(IN2.GT.NNT) CALL ERREUR(12,IN2,NNT,0) EXCR 27 IF(IN2.LE.0) IN2=IN1 EXCR 28 IF(IDLN.GT.NDLN) CALL ERREUR(13,IDLN,NDLN,0) EXCR 29 IF(IDLN.LE.0) IDLN=NDLN EXCR 30 IF(INCR.EQ.0) INCR=1 EXCR 31 I1=(IN2-IN1)/INCR EXCR 32 I2=IN1+I1*INCR EXCR 33 IF(I1.EQ.0)I1=1 EXCR 34 IF(IN2.NE.I2) CALL ERREUR(14,IN2,IN2,0) EXCR 35 C------- GENERATION DES NOEUDS PAR INTERPOLATION EXCR 36 DO 30 I=1,NDIM EXCR 37 X1(I)=X1(I)*FAC(I) EXCR 38 X2(I)=X2(I)*FAC(I) EXCR 39 30 X2(I)=(X2(I)-X1(I))/I1 EXCR 40 I1=0 EXCR 41 I2=(IN1-1)*NDIM+1 EXCR 42 I3=(INCR-1)*NDIM EXCR 43 DO 50 IN=IN1,IN2,INCR EXCR 44 KDLNC(IN+1)=IDLN EXCR 45 IF(VCORG(I2).NE.SPECL) CALL ERREUR(15,IN,IN,0) EXCR 46 DO 40 I=1,NDIM EXCR 47 VCORG(I2)=X1(I)+X2(I)*I1 EXCR 48 40 I2=I2+1 EXCR 49 I1=I1+1 EXCR 50 50 I2=I2+I3 EXCR 51 GO TO 20 EXCR 52 C------- VERIFICATION DES NOEUDS MANQUANTS EXCR 53 60 I1=NNT*NDIM+1 EXCR 54 I2=0 EXCR 55 I3=NNT+1 EXCR 56 DO 90 I=1,NNT EXCR 57 I1=I1-NDIM EXCR 58 I3=I3-1 EXCR 59 IF(VCORG(I1)-SPECL) 70,80,70 EXCR 60 70 IF(I2.EQ.0) I2=I3 EXCR 61 GO TO 90 EXCR 62 80 IF(I2.EQ.0) CALL ERREUR(16,I3,I3,0) EXCR 63 IF(I2.NE.0) CALL ERREUR(17,I3,I3,1) EXCR 64 90 CONTINUE EXCR 65 IF(I2.NE.NNT) CALL ERREUR(18,NNT,I2,0) EXCR 66 C------- NOMBRE TOTAL DE D.L. EXCR 67 NDLT=0 EXCR 68 I1=NNT+1 EXCR 69 DO 100 I=2,I1 EXCR 70 100 NDLT=NDLT+KDLNC(I) EXCR 71 C------- IMPRESSIONS EXCR 72 IF(M.LT.2) GO TO 120 EXCR 73 WRITE(MP,2020) EXCR 74 2020 FORMAT(/10X,'NOEUD D.L.',5X,'X',11X,'Y',11X,'Z'/) EXCR 75 I1=1 EXCR 76 I2=NDIM EXCR 77 DO 110 IN=1,NNT EXCR 78 WRITE(MP,2030) IN,KDLNC(IN+1),(VCORG(I),I=I1,I2) EXCR 79 2030 FORMAT(10X,2I5,3E12.5) EXCR 80 I1=I1+NDIM EXCR 81 110 I2=I2+NDIM EXCR 82 120 RETURN EXCR 83 END EXCR 84 C++++++ FIN FIGURE 6.13 C++++++ DEBUT FIGURE 6.14 SUBROUTINE BLDLPN BLDL 1 C=======================================================================BLDL 2 C APPEL DU BLOC 'DLPN' BLDL 3 C LECTURE DES NOMBRES DE D.L. PAR NOEUD BLDL 4 C=======================================================================BLDL 5 IMPLICIT REAL*8(A-H,O-Z) BLDL 6 COMMON/ES/M,MR,MP,M1 BLDL 7 COMMON/LOC/LCORG,LDLNC BLDL 8 COMMON VA(1) BLDL 9 C-----------------------------------------------------------------------BLDL 10 IF(M1.EQ.0) M1=MR BLDL 11 WRITE(MP,2000) M BLDL 12 2000 FORMAT(//' LECTURE DES D.L. (M=',I2,')'/' ',17('=')) BLDL 13 CALL EXDLPN(VA(LDLNC)) BLDL 14 RETURN BLDL 15 END BLDL 16 SUBROUTINE EXDLPN(KDLNC) EXDL 1 C=======================================================================EXDL 2 C EXECUTION DU BLOC 'DLPN' EXDL 3 C LECTURE DES NOMBRES DE D.L. PAR NOEUD EXDL 4 C=======================================================================EXDL 5 IMPLICIT REAL*8(A-H,O-Z) EXDL 6 COMMON/COOR/NDIM,NNT,NDLN,NDLT EXDL 7 COMMON/ES/M,MR,MP,M1 EXDL 8 COMMON/TRVL/K1(15) EXDL 9 DIMENSION KDLNC(1) EXDL 10 C-----------------------------------------------------------------------EXDL 11 IF(M.GT.0) WRITE(MP,2000) EXDL 12 2000 FORMAT(//' CARTES DE GROUPES DE D.L.'/) EXDL 13 C------- LIRE UNE CARTE DE GROUPE EXDL 14 10 READ(M1,1000) IDLN,K1 EXDL 15 1000 FORMAT(16I5) EXDL 16 IF(M.GT.0) WRITE(MP,2010)IDLN,K1 EXDL 17 2010 FORMAT(' >>>>>',16I5) EXDL 18 IF(IDLN.LE.0) GO TO 40 EXDL 19 IF(IDLN.GT.NDLN) CALL ERREUR(21,IDLN,NDLN,1) EXDL 20 C------- STOCKER LES NOMBRES DE D.L. EXDL 21 20 DO 30 I=1,15 EXDL 22 J=K1(I) EXDL 23 IF(J.LE.0) GO TO 10 EXDL 24 IF(J.GT.NNT) CALL ERREUR(22,J,NNT,1) EXDL 25 30 KDLNC(J+1)=IDLN EXDL 26 READ(M1,1010) K1 EXDL 27 1010 FORMAT(5X,15I5) EXDL 28 IF(M.GT.0) WRITE(MP,2020) K1 EXDL 29 2020 FORMAT(' >>>>>',5X,15I5) EXDL 30 GO TO 20 EXDL 31 C------- NOMBRE TOTAL DE D.L. EXDL 32 40 NDLT=0 EXDL 33 J=NNT+1 EXDL 34 DO 50 I=2,J EXDL 35 50 NDLT=NDLT+KDLNC(I) EXDL 36 RETURN EXDL 37 END EXDL 38 C++++++ FIN FIGURE 6.14 C++++++ DEBUT FIGURE 6.15 SUBROUTINE BLCOND BLCN 1 C=======================================================================BLCN 2 C APPEL DU BLOC 'COND' BLCN 3 C LECTURE DES CONDITIONS AUX LIMITES ET CREATION DE LA TABLE (NEQ) BLCN 4 C=======================================================================BLCN 5 IMPLICIT REAL*8(A-H,O-Z) BLCN 6 REAL*4 TBL BLCN 7 COMMON/COOR/NDIM,NNT,NDLN,NDLT BLCN 8 COMMON/COND/NCLT,NCLZ,NCLNZ BLCN 9 COMMON/ALLOC/NVA,IVA BLCN 10 COMMON/ES/M,MR,MP,M1 BLCN 11 COMMON/LOC/LCORG,LDLNC,LNEQ,LDIMP BLCN 12 COMMON VA(1) BLCN 13 DIMENSION TBL(2) BLCN 14 DATA TBL/4HNEQ ,4HDIMP/ BLCN 15 C-----------------------------------------------------------------------BLCN 16 IF(M1.EQ.0) M1=MR BLCN 17 WRITE(MP,2000) M BLCN 18 2000 FORMAT(//' LECTURE DES CONDITIONS AUX LIMITES (M=',I2,')'/' ', BLCN 19 1 33('=')/) BLCN 20 IF(LNEQ.EQ.1) CALL ESPACE(NDLT,0,TBL(1),LNEQ) BLCN 21 IF(LDIMP.EQ.1) CALL ESPACE(NDLT,1,TBL(2),LDIMP) BLCN 22 CALL EXCOND(VA(LCORG),VA(LDLNC),VA(LNEQ),VA(LDIMP)) BLCN 23 CALL VIDE(LDIMP+NCLT,1,TBL(2)) BLCN 24 RETURN BLCN 25 END BLCN 26 SUBROUTINE EXCOND(VCORG,KDLNC,KNEQ,VDIMP) EXCN 1 C=======================================================================EXCN 2 C EXECUTION DU BLOC 'COND' EXCN 3 C LECTURE DES CONDITIONS AUX LIMITES ET CREATION DE LA TABLE (NEQ) EXCN 4 C=======================================================================EXCN 5 IMPLICIT REAL*8 (A-H,O-Z) EXCN 6 COMMON/COOR/NDIM,NNT,NDLN,NDLT EXCN 7 COMMON/COND/NCLT,NCLZ,NCLNZ EXCN 8 COMMON/RESO/NEQ EXCN 9 COMMON/ES/M,MR,MP,M1 EXCN 10 COMMON/TRVL/ KV(16),V(10),H(20),ICOD(10) EXCN 11 DIMENSION VCORG(1),KDLNC(1),KNEQ(1),VDIMP(1) EXCN 12 DATA L7/7/,L8/8/,L16/16/ ,X1/0.0D0/,X2/0.0D0/,X3/0.0D0/,ZERO/0.D0/EXCN 13 C-----------------------------------------------------------------------EXCN 14 C------- TABLE CUMULATIVE KDLNC EXCN 15 DO 10 IN=1,NNT EXCN 16 10 KDLNC(IN+1)=KDLNC(IN)+KDLNC(IN+1) EXCN 17 I1=NNT+1 EXCN 18 IF(M.GE.2) WRITE(MP,2000) (KDLNC(IN),IN=1,I1) EXCN 19 2000 FORMAT(//' NOMBRE DE D.L. PRECEDANT CHAQUE NOEUD (DLNC)'/ EXCN 20 1 (1X,10I10)) EXCN 21 C------- INITIALISATION EXCN 22 NCLT=0 EXCN 23 NCLNZ=0 EXCN 24 NCLZ=0 EXCN 25 IF(M.GE.0) WRITE(MP,2010) EXCN 26 2010 FORMAT(//' CARTES DE CONDITIONS AUX LIMITES'/) EXCN 27 C------- LIRE UNE CARTE DE GROUPE DE C.L.:10 CODES + VAL.IMPOSEES EXCN 28 20 READ(M1,1000) ICOD,(V(I),I=1,L7) EXCN 29 1000 FORMAT(10I1,7F10.0) EXCN 30 IF(M.GE.0) WRITE(MP,2020) ICOD,(V(I),I=1,L7) EXCN 31 2020 FORMAT(' >>>>>',10I1,7E12.5) EXCN 32 C------- TEST POUR UNE CARTE BLANCHE EXCN 33 J=0 EXCN 34 DO 30 I=1,10 EXCN 35 30 J=J+ICOD(I) EXCN 36 IF(J.EQ.0) GO TO 110 EXCN 37 C------- LIRE UNE CARTE ADDITIONNELLE SI NECESSAIRE EXCN 38 I2=0 EXCN 39 DO 40 ID=1,NDLN EXCN 40 IF(ICOD(ID).LT.2) GO TO 40 EXCN 41 I2=I2+1 EXCN 42 IF(I2.NE.L8) GO TO 40 EXCN 43 READ(M1,1010) (V(I),I=L8,NDLN) EXCN 44 1010 FORMAT(10X,7F10.0) EXCN 45 IF(M.GE.0) WRITE(MP,2030) (V(I),I=L8,NDLN) EXCN 46 2030 FORMAT(' >>>>>',10X,7E12.5) EXCN 47 40 CONTINUE EXCN 48 C------- LECTURE DES CARTES DE NOEUDS EXCN 49 50 READ(M1,1020) (KV(IN),IN=1,L16) EXCN 50 1020 FORMAT(16I5) EXCN 51 IF(M.GE.0) WRITE(MP,2040) (KV(IN),IN=1,L16) EXCN 52 2040 FORMAT(' >>>>>',10X,16I5) EXCN 53 C------- CONSTRUCTION DE NEQ EXCN 54 DO 100 IN=1,L16 EXCN 55 I2=KV(IN) EXCN 56 C------- FIN DE GROUPE DE C.L. OU FIN DE NOEUDS OU ANALYSE DU NOEUD EXCN 57 IF(I2) 20,20,60 EXCN 58 60 IF(I2.GT.NNT) CALL ERREUR(32,I2,NNT,1) EXCN 59 I1=KDLNC(I2) EXCN 60 IDN=KDLNC(I2+1)-I1 EXCN 61 C------- CREER VDIMP ET PLACER DANS KNEQ L ADRESSE DU D.L. IMPOSE EXCN 62 IV=0 EXCN 63 DO 90 ID=1,IDN EXCN 64 I1=I1+1 EXCN 65 IC=ICOD(ID)-1 EXCN 66 IF(IC) 90,70,80 EXCN 67 70 NCLT=NCLT+1 EXCN 68 VDIMP(NCLT)=ZERO EXCN 69 NCLZ=NCLZ+1 EXCN 70 KNEQ(I1)=-NCLT EXCN 71 GO TO 90 EXCN 72 80 NCLT=NCLT+1 EXCN 73 IV=IV+1 EXCN 74 VDIMP(NCLT)=V(IV) EXCN 75 NCLNZ=NCLNZ+1 EXCN 76 KNEQ(I1)=-NCLT EXCN 77 90 CONTINUE EXCN 78 100 CONTINUE EXCN 79 C------- AUTRE CARTE DE NUMEROS DE NOEUDS EXCN 80 GO TO 50 EXCN 81 C------- CREER LES NUMEROS D'EQUATIONS DANS NEQ EXCN 82 110 I1=0 EXCN 83 DO 150 IN=1,NNT EXCN 84 ID=KDLNC(IN) EXCN 85 120 ID=ID+1 EXCN 86 IF(ID.GT.KDLNC(IN+1)) GO TO 150 EXCN 87 IF(KNEQ(ID)) 120,130,120 EXCN 88 130 I1=I1+1 EXCN 89 KNEQ(ID)=I1 EXCN 90 GO TO 120 EXCN 91 150 CONTINUE EXCN 92 NEQ=I1 EXCN 93 C------- IMPRESSIONS EXCN 94 IF(M.LT.0) GO TO 170 EXCN 95 WRITE(MP,2050) NNT,NDLT,NEQ,NCLNZ,NCLZ,NCLT EXCN 96 2050 FORMAT(// EXCN 97 1 15X,'NOMBRE DE NOEUDS TOTAL (NNT)=',I5/ EXCN 98 2 15X,'NOMBRE DE D.L. TOTAL (NDLT)=',I5/ EXCN 99 3 15X,'NOMBRE D EQUATIONS A RESOUDRE (NEQ)=',I5/ EXCN 100 4 15X,'NOMBRE DE D.L. IMPOSES NON NULS (NCLNZ)=',I5/ EXCN 101 5 15X,'NOMBRE DE D.L. IMPOSES NULS (NCLZ)=',I5/ EXCN 102 6 15X,'NOMBRE TOTAL DE D.L. IMPOSES (NCLT)=',I5/) EXCN 103 IF(M.GE.2.AND.NCLT.GT.0) WRITE(MP,2060)(VDIMP(I),I=1,NCLT) EXCN 104 2060 FORMAT(//' VALEURS IMPOSEES (VDIMP)'//(10X,10E12.5)) EXCN 105 WRITE(MP,2070) EXCN 106 2070 FORMAT(//' TABLE DES COORDONNEES DES NOEUDS'// EXCN 107 1 ' NO D.L.',5X,'X',12X,'Y',12X,'Z',10X,'NUMEROS D EQUATIONS EXCN 108 2(NEQ)'/) EXCN 109 I2=0 EXCN 110 DO 160 IN=1,NNT EXCN 111 I1=I2+1 EXCN 112 I2=I2+NDIM EXCN 113 ID1=KDLNC(IN)+1 EXCN 114 ID2=KDLNC(IN+1) EXCN 115 ID=ID2-ID1+1 EXCN 116 IF(ID2.LT.ID1) ID2=ID1 EXCN 117 X1=VCORG(I1) EXCN 118 IF(NDIM.GE.2) X2=VCORG(I1+1) EXCN 119 IF(NDIM.GE.3) X3=VCORG(I1+2) EXCN 120 160 WRITE(MP,2080) IN,ID,X1,X2,X3,(KNEQ(I),I=ID1,ID2) EXCN 121 2080 FORMAT(1X,2I5,3E12.5,10X,10I6) EXCN 122 170 RETURN EXCN 123 END EXCN 124 C++++++ FIN FIGURE 6.15 C++++++ DEBUT FIGURE 6.16 SUBROUTINE BLPRND BLPN 1 C=======================================================================BLPN 2 C APPEL DU BLOC 'PRND' BLPN 3 C LECTURE DES PROPRIETES NODALES BLPN 4 C=======================================================================BLPN 5 IMPLICIT REAL*8(A-H,O-Z) BLPN 6 REAL*4 TBL BLPN 7 COMMON/COOR/NDIM,NNT BLPN 8 COMMON/PRND/NPRN BLPN 9 COMMON/ES/M,MR,MP,M1 BLPN 10 COMMON/LOC/LXX(4),LPRNG BLPN 11 COMMON VA(1) BLPN 12 DATA TBL/4HPRNG/ BLPN 13 C-----------------------------------------------------------------------BLPN 14 IF(M1.EQ.0) M1=MR BLPN 15 READ(M1,1000) NPRN BLPN 16 1000 FORMAT(I5) BLPN 17 WRITE(MP,2000) M,NPRN BLPN 18 2000 FORMAT(//' LECTURE DES PROPRIETES NODALES (M=',I2,')'/' ',30('=')/BLPN 19 1 15X,'NOMBRE DE PROPRIETES PAR NOEUD (NPRN)=',I5) BLPN 20 IF(LPRNG.EQ.1) CALL ESPACE(NNT*NPRN,1,TBL,LPRNG) BLPN 21 CALL EXPRND(VA(LPRNG)) BLPN 22 RETURN BLPN 23 END BLPN 24 SUBROUTINE EXPRND(VPRNG) EXPN 1 C=======================================================================EXPN 2 C EXECUTION DU BLOC 'PRND' EXPN 3 C LECTURE DES PROPRIETES NODALES EXPN 4 C=======================================================================EXPN 5 IMPLICIT REAL*8(A-H,O-Z) EXPN 6 COMMON/COOR/NDIM,NNT EXPN 7 COMMON/PRND/NPRN EXPN 8 COMMON/ES/M,MR,MP,M1 EXPN 9 DIMENSION VPRNG(1) EXPN 10 C-----------------------------------------------------------------------EXPN 11 C------- LIRE LES PROPRIETES NOEUD APRES NOEUD EXPN 12 I1=NNT*NPRN EXPN 13 READ(M1,1000)(VPRNG(I),I=1,I1) EXPN 14 1000 FORMAT(8F10.0) EXPN 15 IF(M.GE.0) WRITE(MP,2000) (VPRNG(I),I=1,I1) EXPN 16 2000 FORMAT(//' CARTES DE PROPRIETES NODALES'/ (' >>>>>',8E12.5)) EXPN 17 RETURN EXPN 18 END EXPN 19 C++++++ FIN FIGURE 6.16 C++++++ DEBUT FIGURE 6.17 SUBROUTINE BLPREL BLPE 1 C=======================================================================BLPE 2 C APPEL DU BLOC 'PREL' BLPE 3 C LECTURE DES PROPRIETES ELEMENTAIRES BLPE 4 C=======================================================================BLPE 5 IMPLICIT REAL*8(A-H,O-Z) BLPE 6 REAL*4 TBL BLPE 7 COMMON/PREL/NGPE,NPRE BLPE 8 COMMON/ES/M,MR,MP,M1 BLPE 9 COMMON/LOC/LXX(5),LPREG BLPE 10 COMMON/TRVL/IN(2) BLPE 11 COMMON VA(1) BLPE 12 DIMENSION TBL(2) BLPE 13 DATA TBL/4HPREG,4HV / BLPE 14 C-----------------------------------------------------------------------BLPE 15 IF(M1.EQ.0) M1=MR BLPE 16 C------- LIRE LE NOMBRE DE GROUPES ET DE PROPRIETES PAR GROUPE BLPE 17 READ(M1,1000) IN BLPE 18 1000 FORMAT(2I5) BLPE 19 IF(IN(1).GT.0) NGPE=IN(1) BLPE 20 IF(IN(2).GT.0) NPRE=IN(2) BLPE 21 WRITE(MP,2000) M,NGPE,NPRE BLPE 22 2000 FORMAT(//' LECTURE DES PROPRIETES ELEMENTAIRES (M=',I2,')'/' ', BLPE 23 1 35('=')/15X,'NOMBRE DE GROUPES DE PROPRIETES (NGPE)=',I5/ BLPE 24 2 15X,'NOMBRE DE PROPRIETES PAR GROUPE (NPRE)=',I5) BLPE 25 IF(LPREG.EQ.1) CALL ESPACE(NGPE*NPRE,1,TBL(1),LPREG) BLPE 26 CALL ESPACE(NPRE,1,TBL(2),L1) BLPE 27 CALL EXPREL(VA(LPREG),VA(L1)) BLPE 28 CALL VIDE(L1,1,TBL(2)) BLPE 29 RETURN BLPE 30 END BLPE 31 SUBROUTINE EXPREL(VPREG,V1) EXPE 1 C=======================================================================EXPE 2 C EXECUTION DU BLOC 'PREL' EXPE 3 C LECTURE DES PROPRIETES ELEMENTAIRES EXPE 4 C=======================================================================EXPE 5 IMPLICIT REAL*8(A-H,O-Z) EXPE 6 COMMON/PREL/NGPE,NPRE EXPE 7 COMMON/ES/M,MR,MP,M1 EXPE 8 DIMENSION VPREG(1),V1(1) EXPE 9 C-----------------------------------------------------------------------EXPE 10 IF(M.GE.0) WRITE(MP,2000) EXPE 11 2000 FORMAT(//' CARTES DE PROPRIETES'/) EXPE 12 C------- LIRE UN GROUPE EXPE 13 I1=MIN0(7,NPRE) EXPE 14 J=1 EXPE 15 10 READ(M1,1000) IGPE,(V1(I),I=1,I1) EXPE 16 1000 FORMAT(I5,7F10.0) EXPE 17 IF(M.GE.0) WRITE(MP,2010) IGPE,(V1(I),I=1,I1) EXPE 18 2010 FORMAT(' >>>>>',I5,7E12.5) EXPE 19 IF(IGPE.LE.0) GO TO 40 EXPE 20 IF(IGPE.GT.NGPE) CALL ERREUR(41,IGPE,NGPE,1) EXPE 21 IF(NPRE.LE.7) GO TO 20 EXPE 22 C------- LIRE LES PROPRIETES EXPE 23 READ(M1,1010) (V1(I),I=8,NPRE) EXPE 24 1010 FORMAT(5X,7F10.0) EXPE 25 IF(M.GE.0) WRITE(MP,2020) (V1(I),I=8,NPRE) EXPE 26 2020 FORMAT(' >>>>>',5X,7E12.5) EXPE 27 20 DO 30 I=1,NPRE EXPE 28 VPREG(J)=V1(I) EXPE 29 30 J=J+1 EXPE 30 GO TO 10 EXPE 31 40 RETURN EXPE 32 END EXPE 33 C++++++ FIN FIGURE 6.17 C++++++ DEBUT FIGURE 6.18 SUBROUTINE BLELEM BLEL 1 C=======================================================================BLEL 2 C APPEL DU BLOC 'ELEM' BLEL 3 C LECTURE DES ELEMENTS BLEL 4 C=======================================================================BLEL 5 IMPLICIT REAL*8(A-H,O-Z) BLEL 6 REAL*4 TBL BLEL 7 COMMON/COOR/NDIM,NNT,NDLN BLEL 8 COMMON/PRND/NPRN BLEL 9 COMMON/PREL/NGPE,NPRE BLEL 10 COMMON/ELEM/NELT,NNEL,NTPE,NGRE,ME,NIDENT,NPG BLEL 11 COMMON/ASSE/NSYM,NKG BLEL 12 COMMON/RESO/NEQ BLEL 13 COMMON/ES/M,MR,MP,M1,M2 BLEL 14 COMMON/LOC/LCORG,LDLNC,LNEQ,LDIMP,LPRNG,LPREG,LLD,LLOCE,LCORE,LNE,BLEL 15 1 LPRNE,LPREE,LDLE,LKE,LFE,LKGS,LKGD,LKGI,LFG,LRES,LDLG BLEL 16 COMMON VA(1) BLEL 17 DIMENSION TBL(6),IN(6) BLEL 18 DATA TBL/4HLD ,4HLOCE,4HCORE,4HNE ,4HPRNE,4HPREE/ BLEL 19 C-----------------------------------------------------------------------BLEL 20 IF(M1.EQ.0) M1=MR BLEL 21 IF(M2.EQ.0) M2=ME BLEL 22 READ(M1,1000)IN BLEL 23 1000 FORMAT(6I5) BLEL 24 IF(IN(1).GT.0) NELT=IN(1) BLEL 25 IF(IN(2).GT.0) NNEL=IN(2) BLEL 26 IF(IN(3).GT.0) NTPE=IN(3) BLEL 27 IF(IN(4).GT.0) NGRE=IN(4) BLEL 28 IF(IN(5).NE.0) NSYM=1 BLEL 29 IF(IN(6).NE.0) NIDENT=1 BLEL 30 WRITE(MP,2000) M,NELT,NNEL,NTPE,NGRE,NSYM,NIDENT BLEL 31 2000 FORMAT(//' LECTURE DES ELEMENTS (M=',I2,')'/' ',20('=')/ BLEL 32 1 15X,'NOMBRE MAX. D ELEMENTS (NELT)=',I5/ BLEL 33 2 15X,'NOMBRE MAX. DE NOEUDS PAR ELEMENT (NNEL)=',I5/ BLEL 34 3 15X,'TYPE D ELEMENT PAR DEFAUT (NTPE)=',I5/ BLEL 35 4 15X,'NOMBRE DE GROUPES D ELEMENTS (NGRE)=',I5/ BLEL 36 5 15X,'INDICE DE PROBLEME NON SYMETRIQUE (NSYM)=',I5/ BLEL 37 6 15X,'INDICE D ELEMENTS IDENTIQUES (NIDENT)=',I5/) BLEL 38 IF(LLD.EQ.1) CALL ESPACE(NEQ+1,0,TBL(1),LLD) BLEL 39 IF(LLOCE.EQ.1) CALL ESPACE(NNEL*NDLN,0,TBL(2),LLOCE) BLEL 40 IF(LCORE.EQ.1) CALL ESPACE(NNEL*NDIM,1,TBL(3),LCORE) BLEL 41 IF(LNE.EQ.1) CALL ESPACE(NNEL,0,TBL(4),LNE) BLEL 42 IF(NPRN.GT.0.AND.LPRNE.EQ.1) CALL ESPACE(NNEL*NPRN,1,TBL(5),LPRNE)BLEL 43 IF(NPRE.GT.0.AND.LPREE.EQ.1) CALL ESPACE(NPRE,1,TBL(6),LPREE) BLEL 44 CALL EXELEM(VA(LCORG),VA(LDLNC),VA(LPRNG),VA(LPREG),VA(LLOCE), BLEL 45 1 VA(LCORE),VA(LNE),VA(LPRNE),VA(LPREE),VA(LNEQ),VA(LLD)) BLEL 46 WRITE(MP,2010) NKG,NPG BLEL 47 2010 FORMAT(15X,'LONGUEUR D UN TRIANGLE DE KG (NKG)=',I10/ BLEL 48 1 15X,'NOMBRE DE POINTS D INTEGRATION (NPG)=',I10/) BLEL 49 RETURN BLEL 50 END BLEL 51 SUBROUTINE EXELEM(VCORG,KDLNC,VPRNG,VPREG,KLOCE,VCORE,KNE,VPRNE, EXEL 1 1 VPREE,KNEQ,KLD) EXEL 2 C=======================================================================EXEL 3 C EXECUTION DU BLOC 'ELEM' EXEL 4 C LECTURE DES ELEMENTS EXEL 5 C=======================================================================EXEL 6 IMPLICIT REAL*8(A-H,O-Z) EXEL 7 COMMON/COOR/NDIM,NNT EXEL 8 COMMON/PRND/NPRN EXEL 9 COMMON/PREL/NGPE,NPRE EXEL 10 COMMON/ELEM/NELT,NNEL,NTPE,NGRE,ME,NIDENT,NPG EXEL 11 COMMON/ASSE/NSYM,NKG,NKE,NDLE EXEL 12 COMMON/RGDT/IEL,ITPE,ITPE1,IGRE,IDLE,ICE,IPRNE,IPREE,INEL,IDEG,IPGEXEL 13 1 ,ICODE,IDLE0,INEL0,IPG0 EXEL 14 COMMON/RESO/NEQ EXEL 15 COMMON/ES/M,MR,MP,M1,M2 EXEL 16 DIMENSION VCORG(1),KDLNC(1),VPRNG(1),VPREG(1),KLOCE(1),VCORE(1), EXEL 17 1 KNE(1),VPRNE(1),VPREE(1),KNEQ(1),KLD(1) EXEL 18 DATA I10/10/,I15/15/ EXEL 19 C-----------------------------------------------------------------------EXEL 20 C------- INITIALISATION EXEL 21 NDLE=0 EXEL 22 IELT=0 EXEL 23 NPG=0 EXEL 24 REWIND M2 EXEL 25 IF(M.GT.0) WRITE(MP,2000) EXEL 26 2000 FORMAT(//' CARTES D ELEMENTS'/) EXEL 27 C------- LIRE UNE CARTE D'ELEMENT EXEL 28 10 READ(M1,1000) IEL,IGEN,INCR,ITPE,IGPE,IGRE,(KNE(IN),IN=1,I10) EXEL 29 1000 FORMAT(16I5) EXEL 30 IF(M.GT.0) WRITE(MP,2010) IEL,IGEN,INCR,ITPE,IGPE,IGRE, EXEL 31 1 (KNE(IN),IN=1,I10) EXEL 32 2010 FORMAT(' >>>>>',16I5) EXEL 33 IF(IEL) 80,80,20 EXEL 34 C------- NOMBRE DE NOEUDS ET LECTURE DE CARTES ADDITIONNELLES EXEL 35 20 INEL=0 EXEL 36 I1=1 EXEL 37 I2=I10 EXEL 38 30 DO 40 IN=I1,I2 EXEL 39 IF(KNE(IN).EQ.0) GO TO 50 EXEL 40 INEL=INEL+1 EXEL 41 40 CONTINUE EXEL 42 I1=I2+1 EXEL 43 I2=I1+I15 EXEL 44 READ(M1,1000) (KNE(IN),IN=I1,I2) EXEL 45 IF(M.GT.0) WRITE(MP,2010) (KNE(IN),IN=I1,I2) EXEL 46 GO TO 30 EXEL 47 C------- VERIFICATIONS EXEL 48 50 IF(INEL.GT.NNEL) CALL ERREUR(51,INEL,NNEL,1) EXEL 49 IF(INCR.EQ.0) INCR=1 EXEL 50 IF(ITPE.EQ.0) ITPE=NTPE EXEL 51 IF(IGPE.GT.NGPE) CALL ERREUR(53,IGPE,NGPE,1) EXEL 52 IF(IGPE.EQ.0) IGPE=1 EXEL 53 IF(IGRE.GT.NGRE) CALL ERREUR(54,IGRE,NGRE,1) EXEL 54 C------- GENERATION DES ELEMENTS EXEL 55 IF(IGEN.EQ.0) IGEN=1 EXEL 56 DO 70 IE=1,IGEN EXEL 57 IF(IEL.GT.NELT) CALL ERREUR(55,IEL,NELT,1) EXEL 58 C------- EXTRACTION DE KLOCE ET MISE A JOUR DE KLD EXEL 59 CALL LOCELD(KDLNC,KNE,KNEQ,KLOCE,KLD) EXEL 60 C------- EXTRACTION DES COORDONNEES ET PROPRIETES DE L'ELEMENT EXEL 61 CALL XTRELM(IGPE,VCORG,VPRNG,VPREG,KNE,VCORE,VPRNE,VPREE) EXEL 62 C------- VERIFICATION DES NOMBRES DE NOEUDS ET DE D.L. DE L'ELEMENT EXEL 63 IPG0=0 EXEL 64 ICODE=1 EXEL 65 CALL ELEMLB(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) EXEL 66 IF(INEL.EQ.INEL0.AND.IDLE.EQ.IDLE0) GO TO 55 EXEL 67 WRITE(MP,2020) IEL,INEL,INEL0,IDLE,IDLE0 EXEL 68 2020 FORMAT(' ** ELEMENT',I5,' INCOHERENT'/5X,'INEL=',I4,' INEL0=',I5/ EXEL 69 1 5X,'IDLE=',I5,' IDLE0=',I5) EXEL 70 C------- METTRE A JOUR LE NOMBRE TOTAL DE POINTS D INTEGRATION EXEL 71 55 NPG=NPG+IPG0 EXEL 72 C------- ECRITURE DU FICHIER DES ELEMENTS EXEL 73 CALL WRELEM(M2,KLOCE,VCORE,VPRNE,VPREE,KNE) EXEL 74 IELT=IELT+1 EXEL 75 C------- IMPRESSION DE L'ELEMENT EXEL 76 CALL PRELEM(KLOCE,VCORE,VPRNE,VPREE,KNE) EXEL 77 C------- PROCHAIN ELEMENT A GENERER OU LIRE EXEL 78 DO 60 IN=1,INEL EXEL 79 60 KNE(IN)=KNE(IN)+INCR EXEL 80 IF(IDLE.GT.NDLE) NDLE=IDLE EXEL 81 70 IEL=IEL+1 EXEL 82 GO TO 10 EXEL 83 C------- VERIFICATION DU NOMBRE TOTAL D ELEMENTS EXEL 84 80 IF(IELT.NE.NELT) CALL ERREUR(57,IELT,NELT,1) EXEL 85 C------- IMPRESSION DES HAUTEURS DE BANDE EXEL 86 IMA=0 EXEL 87 IMO=0 EXEL 88 I1=NEQ+1 EXEL 89 DO 90 I=2,I1 EXEL 90 J=KLD(I) EXEL 91 IF(J.GT.IMA)IMA=J EXEL 92 90 IMO=IMO+J EXEL 93 C=IMO EXEL 94 C=C/NEQ EXEL 95 WRITE(MP,2030) C,IMA EXEL 96 2030 FORMAT(/15X,'HAUTEUR DE BANDE MOYENNE=',F8.1,' MAXIMUM=',I5) EXEL 97 IF(M.GE.2) WRITE(MP,2040) (KLD(I),I=1,I1) EXEL 98 2040 FORMAT(//' TABLE DES HAUTEURS DE BANDE'/(10X,20I5)) EXEL 99 C------- TRANSFORMER KLD EN POINTEURS VERS LES HAUTS DE COLONNES EXEL 100 IF(NSYM.EQ.0) NKE=(NDLE*(NDLE+1))/2 EXEL 101 IF(NSYM.EQ.1) NKE=NDLE*NDLE EXEL 102 KLD(1)=1 EXEL 103 DO 100 ID=2,I1 EXEL 104 100 KLD(ID)=KLD(ID-1)+KLD(ID) EXEL 105 NKG=KLD(I1)-1 EXEL 106 IF(M.GE.2) WRITE(MP,2050) (KLD(ID),ID=1,I1) EXEL 107 2050 FORMAT(//' TABLE DES POINTEURS DE HAUTS DE COLONNES (LD)'/ EXEL 108 1 (10X,20I6)) EXEL 109 RETURN EXEL 110 END EXEL 111 SUBROUTINE LOCELD(KDLNC,KNE,KNEQ,KLOCE,KLD) LOCL 1 C=======================================================================LOCL 2 C CONSTRUCTION DE LA TABLE DE LOCALISATION ELEMENTAIRE (LOCE) LOCL 3 C ET MISE A JOUR DES HAUTEURS DE COLONNES, POUR UN ELEMENT DONNE LOCL 4 C=======================================================================LOCL 5 COMMON/COOR/NDIM,NNT LOCL 6 COMMON/RGDT/NUL(4),IDLE,NUL1(3),INEL LOCL 7 DIMENSION KDLNC(1),KNE(1),KNEQ(1),KLOCE(1),KLD(1) LOCL 8 DATA NDLMAX/32000/ LOCL 9 C-----------------------------------------------------------------------LOCL 10 C------- EXTRAIRE KLOCE DE KNEQ LOCL 11 IDLE=0 LOCL 12 LOCMIN=NDLMAX LOCL 13 DO 20 IN=1,INEL LOCL 14 INN=KNE(IN) LOCL 15 IF(INN.GT.NNT) CALL ERREUR(56,INN,NNT,1) LOCL 16 IEQ=KDLNC(INN) LOCL 17 IEQ1=KDLNC(INN+1) LOCL 18 10 IF(IEQ.GE.IEQ1) GO TO 20 LOCL 19 IEQ=IEQ+1 LOCL 20 IDLE=IDLE+1 LOCL 21 J=KNEQ(IEQ) LOCL 22 KLOCE(IDLE)=J LOCL 23 IF(J.LT.LOCMIN.AND.J.GT.0) LOCMIN=J LOCL 24 GO TO 10 LOCL 25 20 CONTINUE LOCL 26 C------- METTRE A JOUR LA TABLE DES HAUTEURS DE COLONNES (KLD) LOCL 27 DO 30 ID=1,IDLE LOCL 28 J=KLOCE(ID) LOCL 29 IF(J.LE.0) GO TO 30 LOCL 30 IH=J-LOCMIN LOCL 31 IF(IH.GT.KLD(J+1))KLD(J+1)=IH LOCL 32 30 CONTINUE LOCL 33 RETURN LOCL 34 END LOCL 35 SUBROUTINE XTRELM(IGPE,VCORG,VPRNG,VPREG,KNE,VCORE,VPRNE,VPREE) XTRE 1 C=======================================================================XTRE 2 C EXTRACTION DES COORDONNEES ET PROPRIETES ELEMENTAIRES D'UN XTRE 3 C ELEMENT, A PARTIR DES TABLES GLOBALES XTRE 4 C (IGPE: NUMERO DU GROUPE DE PROPRIETE ELEMENTAIRE) XTRE 5 C=======================================================================XTRE 6 IMPLICIT REAL*8(A-H,O-Z) XTRE 7 COMMON/COOR/NDIM XTRE 8 COMMON/PRND/NPRN XTRE 9 COMMON/PREL/NGPE,NPRE XTRE 10 COMMON/RGDT/NUL(5),ICE,IPRNE,IPREE,INEL XTRE 11 DIMENSION VCORG(1),VPRNG(1),VPREG(1),KNE(1),VCORE(1), XTRE 12 1 VPRNE(1),VPREE(1) XTRE 13 C-----------------------------------------------------------------------XTRE 14 C------- EXTRACTION DES COORDONNEES DE L'ELEMENT XTRE 15 IPRNE=0 XTRE 16 ICE=0 XTRE 17 DO 30 IN=1,INEL XTRE 18 IC=(KNE(IN)-1)*NDIM XTRE 19 DO 10 I=1,NDIM XTRE 20 ICE=ICE+1 XTRE 21 IC=IC+1 XTRE 22 10 VCORE(ICE)=VCORG(IC) XTRE 23 C------- EXTRACTION DES PROPRIETES NODALES DE L'ELEMENT XTRE 24 IF(NPRN.EQ.0) GO TO 30 XTRE 25 IC=(KNE(IN)-1)*NPRN XTRE 26 DO 20 I=1,NPRN XTRE 27 IPRNE=IPRNE+1 XTRE 28 IC=IC+1 XTRE 29 20 VPRNE(IPRNE)=VPRNG(IC) XTRE 30 30 CONTINUE XTRE 31 C------- EXTRACTION DES PROPRIETES ELEMENTAIRES DE L'ELEMENT XTRE 32 IPREE=0 XTRE 33 IF(NPRE.EQ.0) GO TO 50 XTRE 34 IC=(IGPE-1)*NPRE XTRE 35 DO 40 I=1,NPRE XTRE 36 IPREE=IPREE+1 XTRE 37 IC=IC+1 XTRE 38 40 VPREE(IPREE)=VPREG(IC) XTRE 39 50 RETURN XTRE 40 END XTRE 41 SUBROUTINE PRELEM(KLOCE,VCORE,VPRNE,VPREE,KNE) PREL 1 C=======================================================================PREL 2 C IMPRESSION DES DONNEES DEFINISSANT UN ELEMENT PREL 3 C=======================================================================PREL 4 IMPLICIT REAL*8(A-H,O-Z) PREL 5 COMMON/PRND/NPRN PREL 6 COMMON/PREL/NGPE,NPRE PREL 7 COMMON/RGDT/IEL,ITPE,ITPE1,IGRE,IDLE,ICE,IPRNE,IPREE,INEL PREL 8 COMMON/ES/M,MR,MP PREL 9 DIMENSION KLOCE(1),VCORE(1),VPRNE(1),VPREE(1),KNE(1) PREL 10 C-----------------------------------------------------------------------PREL 11 IF(M.GE.0) WRITE(MP,2000) IEL,ITPE,INEL,IDLE,IPRNE,IPREE,IGRE PREL 12 2000 FORMAT(10X,'ELEMENT:',I5,' TYPE:',I2,' P.N.:',I2,' D.L.:', PREL 13 1 I3,' PROP N.:',I3,' PROP EL.:',I3,' GROUPE:',I3) PREL 14 IF(M.GE.0) WRITE(MP,2010) (KNE(I),I=1,INEL) PREL 15 2010 FORMAT(15X,'CONNECTIVITE (NE)',20I5/(32X,20I5)) PREL 16 IF(M.LT.1) GO TO 10 PREL 17 WRITE(MP,2020) (KLOCE(I),I=1,IDLE) PREL 18 2020 FORMAT(15X,'LOCALISATN (LOCE)',20I5/(32X,20I5)) PREL 19 WRITE(MP,2030) (VCORE(I),I=1,ICE) PREL 20 2030 FORMAT(15X,'COORDONNEES(CORE)',8E12.5/(32X,8E12.5)) PREL 21 IF(NPRN.GT.0) WRITE(MP,2040) (VPRNE(I),I=1,IPRNE) PREL 22 2040 FORMAT(15X,'PROP.NOD. (PRNE)',8E12.5/(32X,8E12.5)) PREL 23 IF(IPREE.GT.0) WRITE(MP,2050) (VPREE(I),I=1,IPREE) PREL 24 2050 FORMAT(15X,'PROP. ELEM.(PREE)',8E12.5/(32X,8E12.5)) PREL 25 10 RETURN PREL 26 END PREL 27 SUBROUTINE WRELEM(ME,KLOCE,VCORE,VPRNE,VPREE,KNE) WREL 1 C=======================================================================WREL 2 C ECRITURE DES DONNEES ELEMENTAIRES SUR LE FICHIER ME WREL 3 C=======================================================================WREL 4 IMPLICIT REAL*8(A-H,O-Z) WREL 5 COMMON/RGDT/IEL,ITPE,ITPE1,IGRE,IDLE,ICE,IPRNE,IPREE,INEL WREL 6 DIMENSION KLOCE(1),VCORE(1),VPRNE(1),VPREE(1),KNE(1) WREL 7 C-----------------------------------------------------------------------WREL 8 IPRNE1=IPRNE WREL 9 IF(IPRNE1.EQ.0) IPRNE1=1 WREL 10 IPREE1=IPREE WREL 11 IF(IPREE1.EQ.0) IPREE1=1 WREL 12 WRITE(ME)IEL,ITPE,IGRE,IDLE,ICE,IPRNE1,IPREE1,INEL, WREL 13 1 (KLOCE(I),I=1,IDLE),(VCORE(I),I=1,ICE), WREL 14 2 (VPRNE(I),I=1,IPRNE1),(VPREE(I),I=1,IPREE1), WREL 15 3 (KNE(I),I=1,INEL) WREL 16 RETURN WREL 17 END WREL 18 SUBROUTINE RDELEM(ME,KLOCE,VCORE,VPRNE,VPREE,KNE) RDEL 1 C=======================================================================RDEL 2 C LECTURE DES DONNEES ELEMENTAIRES SUR LE FICHIER ME RDEL 3 C=======================================================================RDEL 4 IMPLICIT REAL*8(A-H,O-Z) RDEL 5 COMMON/RGDT/IEL,ITPE,ITPE1,IGRE,IDLE,ICE,IPRNE,IPREE,INEL RDEL 6 DIMENSION KLOCE(1),VCORE(1),VPRNE(1),VPREE(1),KNE(1) RDEL 7 C-----------------------------------------------------------------------RDEL 8 READ(ME) IEL,ITPE,IGRE,IDLE,ICE,IPRNE,IPREE,INEL, RDEL 9 1 (KLOCE(I),I=1,IDLE),(VCORE(I),I=1,ICE), RDEL 10 2 (VPRNE(I),I=1,IPRNE),(VPREE(I),I=1,IPREE), RDEL 11 3 (KNE(I),I=1,INEL) RDEL 12 RETURN RDEL 13 END RDEL 14 C++++++ FIN FIGURE 6.18 C++++++ DEBUT FIGURE 6.19 SUBROUTINE BLSOLC BLSC 1 C=======================================================================BLSC 2 C APPEL DU BLOC 'SOLC' BLSC 3 C LECTURE DES SOLLICITATIONS CONCENTREES BLSC 4 C=======================================================================BLSC 5 IMPLICIT REAL*8(A-H,O-Z) BLSC 6 REAL*4 TBL BLSC 7 COMMON/RESO/NEQ BLSC 8 COMMON/ES/M,MR,MP,M1 BLSC 9 COMMON/LOC/LCORG,LDLNC,LNEQ,LXX(15),LFG BLSC 10 COMMON VA(1) BLSC 11 DATA TBL/4HFG / BLSC 12 C-----------------------------------------------------------------------BLSC 13 IF(M1.EQ.0) M1=MR BLSC 14 WRITE(MP,2000) M BLSC 15 2000 FORMAT(//' LECTURE DES SOLLICITATIONS CONCENTREES (M=',I2,')'/' ',BLSC 16 1 39('=')) BLSC 17 IF(LFG.EQ.1) CALL ESPACE(NEQ,1,TBL,LFG) BLSC 18 CALL EXSOLC(VA(LFG),VA(LDLNC),VA(LNEQ)) BLSC 19 RETURN BLSC 20 END BLSC 21 SUBROUTINE EXSOLC(VFG,KDLNC,KNEQ) EXSC 1 C=======================================================================EXSC 2 C EXECUTION DU BLOC 'SOLC' EXSC 3 C LECTURE DES SOLLICITATIONS CONCENTREES EXSC 4 C====================================================================== EXSC 5 IMPLICIT REAL*8 (A-H,O-Z) EXSC 6 COMMON/COOR/NDIM,NNT,NDLN EXSC 7 COMMON/RESO/NEQ EXSC 8 COMMON/ES/M,MR,MP,M1 EXSC 9 COMMON/TRVL/KV(16),V(14) EXSC 10 DIMENSION VFG(1),KDLNC(1),KNEQ(1) EXSC 11 DATA L16/16/ EXSC 12 C-----------------------------------------------------------------------EXSC 13 C------- LECTURE DES DONNEES EXSC 14 IF(M.GE.0)WRITE(MP,2000) EXSC 15 2000 FORMAT(//' CARTES DE SOLLICITATIONS NODALES'//) EXSC 16 I0=MIN0(7,NDLN) EXSC 17 10 READ(M1,1000) IG,(V(I),I=1,I0) EXSC 18 1000 FORMAT(I5,7F10.0) EXSC 19 IF(NDLN.GT.7) READ(M1,1005) (V(I),I=8,NDLN) EXSC 20 1005 FORMAT(5X,7F10.0) EXSC 21 IF(M.GE.0)WRITE(MP,2010)IG,(V(I),I=1,NDLN) EXSC 22 2010 FORMAT(' >>>>>',I5,7E12.5/(' >>>>>',5X,7E12.5)) EXSC 23 IF(IG.LE.0) GO TO 60 EXSC 24 20 READ(M1,1010)(KV(I),I=1,L16) EXSC 25 1010 FORMAT(16I5) EXSC 26 IF(M.GE.0)WRITE(MP,2020)(KV(I),I=1,L16) EXSC 27 2020 FORMAT(' >>>>>',16I5) EXSC 28 C----- EXPLORATION DES NOEUDS EXSC 29 DO 50 IN=1,L16 EXSC 30 I1=KV(IN) EXSC 31 IF(I1.GT.NNT) CALL ERREUR(61,I1,NNT,1) EXSC 32 IF(I1)10,10,30 EXSC 33 30 ID1=KDLNC(I1)+1 EXSC 34 ID2=KDLNC(I1+1) EXSC 35 J=0 EXSC 36 DO 50 ID=ID1,ID2 EXSC 37 J=J+1 EXSC 38 IEQ=KNEQ(ID) EXSC 39 IF(IEQ)50,50,40 EXSC 40 40 VFG(IEQ)=VFG(IEQ)+V(J) EXSC 41 50 CONTINUE EXSC 42 GO TO 20 EXSC 43 C----- IMPRESSION EXSC 44 60 IF(M.GE.1)WRITE(MP,2030)(VFG(I),I=1,NEQ) EXSC 45 2030 FORMAT(//' VECTEUR SOLLICITATION TOTAL'/(10X,10E12.5)) EXSC 46 RETURN EXSC 47 END EXSC 48 C++++++ FIN FIGURE 6.19 C++++++ DEBUT FIGURE 6.21 SUBROUTINE BLSOLR BLSR 1 C=======================================================================BLSR 2 C APPEL DU BLOC 'SOLR' BLSR 3 C ASSEMBLAGE DES SOLLICITATIONS REPARTIES (FONCTION ELEMENTAIRE 7) BLSR 4 C=======================================================================BLSR 5 IMPLICIT REAL*8(A-H,O-Z) BLSR 6 REAL*4 TBL BLSR 7 COMMON/COOR/NDIM,NNT,NDLN,NDLT BLSR 8 COMMON/ELEM/NUL(4),ME BLSR 9 COMMON/ASSE/NSYM,NKG,NKE,NDLE BLSR 10 COMMON/RESO/NEQ,NRES,MRES BLSR 11 COMMON/ES/M,MR,MP,M1,M2 BLSR 12 COMMON/LOC/LCORG,LDLNC,LNEQ,LDIMP,LPRNG,LPREG,LLD,LLOCE,LCORE,LNE,BLSR 13 1 LPRNE,LPREE,LDLE,LKE,LFE,LKGS,LKGD,LKGI,LFG,LRES,LDLG BLSR 14 COMMON VA(1) BLSR 15 DIMENSION TBL(8) BLSR 16 DATA TBL/4HFG ,4HKE ,4HFE ,4HDLE ,4HKGS ,4HKGD ,4HKGI , BLSR 17 1 4HRES / BLSR 18 C-----------------------------------------------------------------------BLSR 19 IF(M1.EQ.0) M1=MR BLSR 20 IF(M2.EQ.0) M2=ME BLSR 21 WRITE(MP,2000) M BLSR 22 2000 FORMAT(//' ASSEMBLAGE DES SOLLICITATIONS REPARTIES (M=',I2,')'/ BLSR 23 1 1X,40('=')/) BLSR 24 IF(LFG.EQ.1) CALL ESPACE(NEQ,1,TBL(1),LFG) BLSR 25 IF(LKE.EQ.1) CALL ESPACE(NKE,1,TBL(2),LKE) BLSR 26 IF(LFE.EQ.1) CALL ESPACE(NDLE,1,TBL(3),LFE) BLSR 27 IF(LDLE.EQ.1) CALL ESPACE(NDLE,1,TBL(4),LDLE) BLSR 28 IF(LKGS.EQ.1) CALL ESPACE(NKG,1,TBL(5),LKGS) BLSR 29 IF(LKGD.EQ.1) CALL ESPACE(NEQ,1,TBL(6),LKGD) BLSR 30 IF(NSYM.EQ.1.AND.LKGI.EQ.1) CALL ESPACE(NKG,1,TBL(7),LKGI) BLSR 31 IF(LRES.EQ.1) CALL ESPACE(NDLT,1,TBL(8),LRES) BLSR 32 CALL EXSOLR(VA(LLD),VA(LDIMP),VA(LLOCE),VA(LCORE),VA(LPRNE), BLSR 33 1 VA(LPREE),VA(LNE),VA(LKE),VA(LFE),VA(LKGS),VA(LKGD), BLSR 34 2 VA(LKGI),VA(LFG),VA(LCORG),VA(LDLNC),VA(LNEQ), BLSR 35 3 VA(LRES),VA(LDLE)) BLSR 36 RETURN BLSR 37 END BLSR 38 SUBROUTINE EXSOLR(KLD,VDIMP,KLOCE,VCORE,VPRNE,VPREE,KNE,VKE,VFE, EXSR 1 1 VKGS,VKGD,VKGI,VFG,VCORG,KDLNC,KNEQ,VRES,VDLE) EXSR 2 C=======================================================================EXSR 3 C EXECUTION DU BLOC 'SOLR' EXSR 4 C ASSEMBLAGE DES SOLLICITATIONS REPARTIES (FONCTION ELEMENTAIRE 7) EXSR 5 C=======================================================================EXSR 6 IMPLICIT REAL*8(A-H,O-Z) EXSR 7 COMMON/ASSE/NSYM,NKG,NKE,NDLE EXSR 8 COMMON/RESO/NEQ,NRES EXSR 9 COMMON/ES/M,MR,MP,M1,M2 EXSR 10 DIMENSION KLD(1),VDIMP(1),KLOCE(1),VCORE(1),VPRNE(1),VPREE(1), EXSR 11 1 KNE(1),VKE(1),VFE(1),VKGS(1),VKGD(1),VKGI(1),VFG(1),VCORG(1), EXSR 12 2 KDLNC(1),KNEQ(1),VRES(1),VDLE(1) EXSR 13 C-----------------------------------------------------------------------EXSR 14 C----- ASSEMBLER FG EXSR 15 CALL ASFG(KLD,VDIMP,KLOCE,VCORE,VPRNE,VPREE,KNE,VKE,VFE,VKGS, EXSR 16 1 VKGD,VKGI,VFG,VDLE,VRES) EXSR 17 C------- IMPRESSION EXSR 18 IF(M.GE.1) WRITE(MP,2000) (VFG(I),I=1,NEQ) EXSR 19 2000 FORMAT(/' VECTEUR SOLLICITATIONS GLOBAL (FG)'/(1X,10E12.5)) EXSR 20 RETURN EXSR 21 END EXSR 22 SUBROUTINE ASFG(KLD,VDIMP,KLOCE,VCORE,VPRNE,VPREE,KNE,VKE,VFE, ASFG 1 1 VKGS,VKGD,VKGI,VFG,VDLE,VRES) ASFG 2 C=======================================================================ASFG 3 C ASSEMBLAGE DE FG DUE AUX SOLLICITATIONS REPARTIES (FONCTION 7) ASFG 4 C=======================================================================ASFG 5 IMPLICIT REAL*8(A-H,O-Z) ASFG 6 COMMON/ELEM/NELT,NNEL,NTPE,NGRE,ME,NIDENT ASFG 7 COMMON/ASSE/NSYM ASFG 8 COMMON/RESO/NEQ ASFG 9 COMMON/RGDT/IEL,ITPE,ITPE1,IGRE,IDLE,ICE,IPRNE,IPREE,INEL,IDEG,IPGASFG 10 1 ,ICOD ASFG 11 COMMON/ES/M,MR,MP,M1,M2 ASFG 12 DIMENSION KLD(1),VDIMP(1),KLOCE(1),VCORE(1),VPRNE(1),VPREE(1), ASFG 13 1 KNE(1),VKE(1),VFE(1),VKGS(1),VKGD(1),VKGI(1),VFG(1),VDLE(1), ASFG 14 2 VRES(1) ASFG 15 C-----------------------------------------------------------------------ASFG 16 C------- POSITIONNER AU DEBUT LE FICHIER DES ELEMENTS (M2) ASFG 17 REWIND M2 ASFG 18 C------- BOUCLE SUR LES ELEMENTS ASFG 19 DO 20 IE=1,NELT ASFG 20 C------- LIRE UN ELEMENT SUR LE FICHIER M2 ASFG 21 CALL RDELEM(M2,KLOCE,VCORE,VPRNE,VPREE,KNE) ASFG 22 C------- CALCUL DES FONCTIONS D'INTERPOLATION SI NECESSAIRE ASFG 23 IF(ITPE.EQ.ITPE1) GO TO 10 ASFG 24 ICOD=2 ASFG 25 CALL ELEMLB(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ASFG 26 C------- CALCUL DU VECTEUR ELEMENTAIRE ASFG 27 10 ICOD=7 ASFG 28 CALL ELEMLB(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ASFG 29 C------- IMPRESSION DU VECTEUR ELEMENTAIRE VFE ASFG 30 IF(M.GE.2) WRITE(MP,2000) IEL,(VFE(I),I=1,IDLE) ASFG 31 2000 FORMAT(/' VECTEUR (FE) , ELEMENT:',I5/(10X,10E12.5)) ASFG 32 C------- ASSEMBLAGE ASFG 33 CALL ASSEL(0,1,IDLE,NSYM,KLOCE,KLD,VKE,VFE,VKGS,VKGD,VKGI,VFG) ASFG 34 20 ITPE1=ITPE ASFG 35 RETURN ASFG 36 END ASFG 37 C++++++ FIN FIGURE 6.21 C++++++ DEBUT FIGURE 6.22 SUBROUTINE BLLINM BLLM 1 C=======================================================================BLLM 2 C APPEL DU BLOC 'LINM' BLLM 3 C ASSEMBLAGE ET RESOLUTION D'UN PROBLEME LINEAIRE EN MEMOIRE BLLM 4 C=======================================================================BLLM 5 IMPLICIT REAL*8(A-H,O-Z) BLLM 6 REAL*4 TBL BLLM 7 COMMON/COOR/NDIM,NNT,NDLN,NDLT BLLM 8 COMMON/ELEM/NUL(4),ME BLLM 9 COMMON/ASSE/NSYM,NKG,NKE,NDLE BLLM 10 COMMON/RESO/NEQ,NRES,MRES BLLM 11 COMMON/ES/M,MR,MP,M1,M2,M3 BLLM 12 COMMON/LOC/LCORG,LDLNC,LNEQ,LDIMP,LPRNG,LPREG,LLD,LLOCE,LCORE,LNE,BLLM 13 1 LPRNE,LPREE,LDLE,LKE,LFE,LKGS,LKGD,LKGI,LFG,LRES,LDLG BLLM 14 COMMON VA(1) BLLM 15 DIMENSION TBL(8) BLLM 16 DATA TBL/4HKGS ,4HKGD ,4HKGI ,4HFG ,4HKE ,4HFE ,4HRES ,4HDLE / BLLM 17 C-----------------------------------------------------------------------BLLM 18 IF(M1.EQ.0) M1=MR BLLM 19 IF(M2.EQ.0) M2=ME BLLM 20 IF(M3.EQ.0) M3=MRES BLLM 21 READ(M1,1000) IN BLLM 22 1000 FORMAT(1I5) BLLM 23 IF(IN.NE.0) NRES=1 BLLM 24 WRITE(MP,2000) M,NRES BLLM 25 2000 FORMAT(//' ASSEMBLAGE-RESOLUTION LINEAIRE (M=',I2,')'/' ',30('=')/BLLM 26 1 15X,' INDICE DE CALCUL DU RESIDU (NRES)=',I5) BLLM 27 IF(LKGS.EQ.1) CALL ESPACE(NKG,1,TBL(1),LKGS) BLLM 28 IF(LKGD.EQ.1) CALL ESPACE(NEQ,1,TBL(2),LKGD) BLLM 29 IF(NSYM.EQ.1.AND.LKGI.EQ.1) CALL ESPACE(NKG,1,TBL(3),LKGI) BLLM 30 IF(LFG.EQ.1) CALL ESPACE(NEQ,1,TBL(4),LFG) BLLM 31 IF(LKE.EQ.1) CALL ESPACE(NKE,1,TBL(5),LKE) BLLM 32 IF(LFE.EQ.1) CALL ESPACE(NDLE,1,TBL(6),LFE) BLLM 33 IF(LRES.EQ.1) CALL ESPACE(NDLT,1,TBL(7),LRES) BLLM 34 IF(LDLE.EQ.1) CALL ESPACE(NDLE,1,TBL(8),LDLE) BLLM 35 CALL EXLINM(VA(LLD),VA(LDIMP),VA(LLOCE),VA(LCORE),VA(LPRNE), BLLM 36 1 VA(LPREE),VA(LNE),VA(LKE),VA(LFE),VA(LKGS),VA(LKGD), BLLM 37 2 VA(LKGI),VA(LFG),VA(LCORG),VA(LDLNC),VA(LNEQ), BLLM 38 3 VA(LRES),VA(LDLE)) BLLM 39 RETURN BLLM 40 END BLLM 41 SUBROUTINE EXLINM(KLD,VDIMP,KLOCE,VCORE,VPRNE,VPREE,KNE,VKE,VFE, EXLM 1 1 VKGS,VKGD,VKGI,VFG,VCORG,KDLNC,KNEQ,VRES,VDLE) EXLM 2 C=======================================================================EXLM 3 C EXECUTION DU BLOC 'LINM' EXLM 4 C ASSEMBLAGE ET RESOLUTION D'UN PROBLEME LINEAIRE EN MEMOIRE EXLM 5 C=======================================================================EXLM 6 IMPLICIT REAL*8(A-H,O-Z) EXLM 7 COMMON/ASSE/NSYM,NKG,NKE,NDLE EXLM 8 COMMON/RESO/NEQ,NRES,MRES EXLM 9 COMMON/ES/M,MR,MP,M1,M2,M3 EXLM 10 DIMENSION KLD(1),VDIMP(1),KLOCE(1),VCORE(1),VPRNE(1),VPREE(1), EXLM 11 1 KNE(1),VKE(1),VFE(1),VKGS(1),VKGD(1),VKGI(1),VFG(1),VCORG(1), EXLM 12 2 KDLNC(1),KNEQ(1),VRES(1),VDLE(1) EXLM 13 C-----------------------------------------------------------------------EXLM 14 REWIND M3 EXLM 15 C EXLM 16 C------- ASSEMBLER KG EXLM 17 C EXLM 18 C------- SAUVER SUR M3 LE VECTEUR FG NON MODIFIE PAR LES C.L. EXLM 19 WRITE(M3) (VFG(I),I=1,NEQ) EXLM 20 IF(M.GE.2) WRITE(MP,2000) (VFG(I),I=1,NEQ) EXLM 21 2000 FORMAT(/' VECTEUR SOLLICITATIONS GLOBAL NON MODIFIE PAR LES C.L. (EXLM 22 1FG)'/(1X,10E12.5)) EXLM 23 C------- ASSEMBLER KG,MODIFIER FG POUR LES C.L. ET LES SAUVER EXLM 24 CALL ASKG(KLD,VDIMP,KLOCE,VCORE,VPRNE,VPREE,KNE,VKE,VFE,VKGS, EXLM 25 1 VKGD,VKGI,VFG,VDLE,VRES) EXLM 26 WRITE(M3) (VFG(I),I=1,NEQ) EXLM 27 WRITE(M3) (VKGS(I),I=1,NKG),(VKGD(I),I=1,NEQ) EXLM 28 IF(NSYM.EQ.1) WRITE(M3) (VKGI(I),I=1,NKG) EXLM 29 C------- IMPRESSION DE KG ET FG EXLM 30 IF(M.LT.2) GO TO 20 EXLM 31 WRITE(MP,2005) (VKGS(I),I=1,NKG) EXLM 32 2005 FORMAT(/' MATRICE GLOBALE (KG)'/' TRIANGLE SUPERIEUR'/ EXLM 33 1 (1X,10E12.5)) EXLM 34 WRITE(MP,2010) (VKGD(I),I=1,NEQ) EXLM 35 2010 FORMAT(' DIAGONALE'/(1X,10E12.5)) EXLM 36 IF(NSYM.EQ.1) WRITE(MP,2020) (VKGI(I),I=1,NKG) EXLM 37 2020 FORMAT(' TRIANGLE INFERIEUR'/(1X,10E12.5)) EXLM 38 WRITE(MP,2030) (VFG(I),I=1,NEQ) EXLM 39 2030 FORMAT(/' VECTEUR SOLLICITATIONS GLOBAL MODIFIE PAR LES C.L. (FG)'EXLM 40 1 /(1X,10E12.5)) EXLM 41 C EXLM 42 C------- RESOLUTION EXLM 43 C EXLM 44 20 CALL SOL(VKGS,VKGD,VKGI,VFG,KLD,NEQ,MP,1,1,NSYM,ENERG) EXLM 45 IF(NSYM.NE.1) WRITE(MP,2035) ENERG EXLM 46 2035 FORMAT(15X,'ENERGIE (ENERG)=',1E12.5) EXLM 47 IF(M.LT.2) GO TO 30 EXLM 48 WRITE(MP,2040) (VKGS(I),I=1,NKG) EXLM 49 2040 FORMAT(/' MATRICE TRIANGULARISEE (KG)'/' TRIANGLE SUPERIEUR'/ EXLM 50 1 (1X,10E12.5)) EXLM 51 WRITE(MP,2010) (VKGD(I),I=1,NEQ) EXLM 52 IF(NSYM.EQ.1) WRITE(MP,2020) (VKGI(I),I=1,NKG) EXLM 53 C------- PIVOTS DE KG ET DETERMINANT EXLM 54 30 CALL PRPVTS(VKGD) EXLM 55 C------- CALCUL ET IMPRESSION DES RESIDUS DE RESOLUTION K.U - F EXLM 56 IF(NRES.EQ.1) CALL PRRESD(VKGS,VKGD,VKGI,VFG,KLD,VRES) EXLM 57 C------- IMPRESSION DE LA SOLUTION EXLM 58 WRITE(MP,2050) EXLM 59 2050 FORMAT(//' SOLUTION'//) EXLM 60 CALL PRSOL(KDLNC,VCORG,VDIMP,KNEQ,VFG) EXLM 61 C EXLM 62 C------- CALCUL ET IMPRESSION DES GRADIENTS (CONTRAINTES) EXLM 63 C EXLM 64 CALL ASGRAD(KLD,VDIMP,KLOCE,VCORE,VPRNE,VPREE,KNE,VKE,VFE,VKGS, EXLM 65 1 VKGD,VKGI,VFG,VDLE,VRES) EXLM 66 C EXLM 67 C------- CALCUL ET IMPRESSION DES RESIDUS D'EQUILIBRE EXLM 68 C EXLM 69 C------- LIRE LE VECTEUR FG ET LE CHANGER DE SIGNE EXLM 70 REWIND M3 EXLM 71 READ(M3) (VRES(I),I=1,NEQ) EXLM 72 DO 40 I=1,NEQ EXLM 73 40 VRES(I)=-VRES(I) EXLM 74 C------- ASSEMBLER LES RESIDUS EXLM 75 CALL ASRESD(1,1,KLD,VDIMP,KLOCE,VCORE,VPRNE,VPREE,KNE,VKE,VFE, EXLM 76 1 VKGS,VKGD,VKGI,VFG,VDLE,VRES,VRES(NEQ+1)) EXLM 77 C------- IMPRESSION DES RESIDUS EXLM 78 WRITE(MP,2060) EXLM 79 2060 FORMAT(//' RESIDUS D EQUILIBRE ET REACTIONS'//) EXLM 80 CALL PRSOL(KDLNC,VCORG,VRES(NEQ+1),KNEQ,VRES) EXLM 81 RETURN EXLM 82 END EXLM 83 SUBROUTINE ASKG(KLD,VDIMP,KLOCE,VCORE,VPRNE,VPREE,KNE,VKE,VFE, ASKG 1 1 VKGS,VKGD,VKGI,VFG,VDLE,VRES) ASKG 2 C=======================================================================ASKG 3 C ASSEMBLAGE DE LA MATRICE GLOBALE KG (FONCTION ELEMENTAIRE 3) ASKG 4 C AVEC PRISE EN COMPTE DES D.L. IMPOSES NON NULS ASKG 5 C=======================================================================ASKG 6 IMPLICIT REAL*8(A-H,O-Z) ASKG 7 COMMON/COND/NCLT,NCLZ,NCLNZ ASKG 8 COMMON/ELEM/NELT,NNEL,NTPE,NGRE,ME,NIDENT ASKG 9 COMMON/ASSE/NSYM ASKG 10 COMMON/RESO/NEQ ASKG 11 COMMON/RGDT/IEL,ITPE,ITPE1,IGRE,IDLE,ICE,IPRNE,IPREE,INEL,IDEG,IPGASKG 12 1 ,ICOD ASKG 13 COMMON/ES/M,MR,MP,M1,M2 ASKG 14 DIMENSION KLD(1),VDIMP(1),KLOCE(1),VCORE(1),VPRNE(1),VPREE(1), ASKG 15 1 KNE(1),VKE(1),VFE(1),VKGS(1),VKGD(1),VKGI(1),VFG(1),VDLE(1), ASKG 16 2 VRES(1),KEB(1) ASKG 17 C-----------------------------------------------------------------------ASKG 18 C------- POSITIONNER AU DEBUT LE FICHIER DES ELEMENTS (M2) ASKG 19 REWIND M2 ASKG 20 C------- BOUCLE SUR LES ELEMENTS ASKG 21 DO 30 IE=1,NELT ASKG 22 C------- LIRE UN ELEMENT ASKG 23 CALL RDELEM(M2,KLOCE,VCORE,VPRNE,VPREE,KNE) ASKG 24 C------- NE PAS RECALCULER LES ELEMENTS IDENTIQUES ASKG 25 IF(NIDENT.EQ.1.AND.IE.GT.1) GO TO 20 ASKG 26 C------- CALCUL DES FONCTIONS D'INTERPOLATION SI NECESSAIRE ASKG 27 IF(ITPE.EQ.ITPE1) GO TO 10 ASKG 28 ICOD=2 ASKG 29 CALL ELEMLB(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ASKG 30 C------- CALCUL DE LA MATRICE ELEMENTAIRE ASKG 31 10 ICOD=3 ASKG 32 CALL ELEMLB(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ASKG 33 C------- IMPRESSION DE LA MATRICE ELEMENTAIRE ASKG 34 IF(M.LT.2) GO TO 20 ASKG 35 IF(NSYM.EQ.0) IKE=IDLE*(IDLE+1)/2 ASKG 36 IF(NSYM.EQ.1) IKE=IDLE*IDLE ASKG 37 WRITE(MP,2000) IEL,(VKE(I),I=1,IKE) ASKG 38 2000 FORMAT(/' MATRICE (KE) , ELEMENT:',I5/(10X,10E12.5)) ASKG 39 C------- MODIFICATION DE FG DUE AUX D.L. IMPOSES NON NULS ASKG 40 20 IF(NCLNZ.NE.0) CALL MODFG(IDLE,NSYM,KLOCE,VDIMP,VKE,VFG) ASKG 41 C------- ASSEMBLAGE ASKG 42 CALL ASSEL(1,0,IDLE,NSYM,KLOCE,KLD,VKE,VFE,VKGS,VKGD,VKGI,VFG) ASKG 43 30 ITPE1=ITPE ASKG 44 RETURN ASKG 45 END ASKG 46 SUBROUTINE ASGRAD(KLD,VDIMP,KLOCE,VCORE,VPRNE,VPREE,KNE,VKE,VFE, ASGR 1 1 VKGS,VKGD,VKGI,VFG,VDLE,VRES) ASGR 2 C=======================================================================ASGR 3 C CALCUL ET IMPRESSION DES GRADIENTS (CONTRAINTES) AUX P.G. DES ASGR 4 C ELEMENTS (FONCTION ELEMENTAIRE 8) ASGR 5 C=======================================================================ASGR 6 IMPLICIT REAL*8(A-H,O-Z) ASGR 7 COMMON/ELEM/NELT,NNEL,NTPE,NGRE,ME,NIDENT ASGR 8 COMMON/ASSE/NSYM ASGR 9 COMMON/RESO/NEQ ASGR 10 COMMON/RGDT/IEL,ITPE,ITPE1,IGRE,IDLE,ICE,IPRNE,IPREE,INEL,IDEG,IPGASGR 11 1 ,ICOD ASGR 12 COMMON/ES/M,MR,MP,M1,M2 ASGR 13 DIMENSION KLD(1),VDIMP(1),KLOCE(1),VCORE(1),VPRNE(1),VPREE(1), ASGR 14 1 KNE(1),VKE(1),VFE(1),VKGS(1),VKGD(1),VKGI(1),VFG(1),VDLE(1), ASGR 15 2 VRES(1) ASGR 16 C-----------------------------------------------------------------------ASGR 17 C------- POSITIONNER AU DEBUT LE FICHIER DES ELEMENTS (M2) ASGR 18 REWIND M2 ASGR 19 C------- BOUCLE SUR LES ELEMENTS ASGR 20 DO 20 IE=1,NELT ASGR 21 C------- LIRE UN ELEMENT ASGR 22 CALL RDELEM(M2,KLOCE,VCORE,VPRNE,VPREE,KNE) ASGR 23 C------- CALCUL DES FONCTIONS D'INTERPOLATION SI NECESSAIRE ASGR 24 IF(ITPE.EQ.ITPE1) GO TO 10 ASGR 25 ICOD=2 ASGR 26 CALL ELEMLB(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ASGR 27 C------- EXTRAIRE LES D.L. DE L'ELEMENT ASGR 28 10 CALL DLELM(KLOCE,VFG,VDIMP,VDLE) ASGR 29 C------- CALCUL ET IMPRESSION DES CONTRAINTES OU GRADIENTS ASGR 30 ICOD=8 ASGR 31 CALL ELEMLB(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ASGR 32 20 ITPE1=ITPE ASGR 33 RETURN ASGR 34 END ASGR 35 SUBROUTINE ASRESD(IRESD,IREAC,KLD,VDIMP,KLOCE,VCORE,VPRNE,VPREE, ASRE 1 1 KNE,VKE,VFE,VKGS,VKGD,VKGI,VFG,VDLE,VRES,VREAC) ASRE 2 C=======================================================================ASRE 3 C ASSEMBLAGE DES RESIDUS INTERNES DANS VRES (SI IRESD.EQ.1) ASRE 4 C ET DES REACTIONS EXTERNES DANS VREAC (SI IREAC.EQ.1) ASRE 5 C=======================================================================ASRE 6 IMPLICIT REAL*8(A-H,O-Z) ASRE 7 COMMON/ELEM/NELT,NNEL,NTPE,NGRE,ME,NIDENT ASRE 8 COMMON/ASSE/NSYM ASRE 9 COMMON/RESO/NEQ ASRE 10 COMMON/RGDT/IEL,ITPE,ITPE1,IGRE,IDLE,ICE,IPRNE,IPREE,INEL,IDEG,IPGASRE 11 1 ,ICOD ASRE 12 COMMON/ES/M,MR,MP,M1,M2 ASRE 13 DIMENSION KLD(1),VDIMP(1),KLOCE(1),VCORE(1),VPRNE(1),VPREE(1), ASRE 14 1 KNE(1),VKE(1),VFE(1),VKGS(1),VKGD(1),VKGI(1),VFG(1),VDLE(1), ASRE 15 2 VRES(1),VREAC(1) ASRE 16 C-----------------------------------------------------------------------ASRE 17 C------- POSITIONNER AU DEBUT LE FICHIER DES ELEMENTS (M2) ASRE 18 REWIND M2 ASRE 19 C------- BOUCLE SUR LES ELEMENTS ASRE 20 DO 60 IE=1,NELT ASRE 21 C------- LIRE UN ELEMENT ASRE 22 CALL RDELEM(M2,KLOCE,VCORE,VPRNE,VPREE,KNE) ASRE 23 C------- CALCUL DES FONCTIONS D'INTERPOLATION SI NECESSAIRE ASRE 24 IF(ITPE.EQ.ITPE1) GO TO 10 ASRE 25 ICOD=2 ASRE 26 CALL ELEMLB(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ASRE 27 C------- EXTRAIRE LES D.L. DE L'ELEMENT ASRE 28 10 CALL DLELM(KLOCE,VFG,VDIMP,VDLE) ASRE 29 C------- CALCUL DES REACTIONS ELEMENTAIRES ASRE 30 ICOD=6 ASRE 31 CALL ELEMLB(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ASRE 32 C------- IMPRESSION DES REACTIONS ELEMENTAIRES ASRE 33 IF(M.GE.2) WRITE(MP,2000) IEL,(VFE(I),I=1,IDLE) ASRE 34 2000 FORMAT(/' REACTIONS (FE) , ELEMENT:',I5/(10X,10E12.5)) ASRE 35 IF(IRESD.NE.1) GO TO 20 ASRE 36 C------- ASSEMBLAGE DES RESIDUS INTERNES ASRE 37 CALL ASSEL(0,1,IDLE,NSYM,KLOCE,KLD,VKE,VFE,VKGS,VKGD,VKGI,VRES) ASRE 38 20 IF(IREAC.NE.1) GO TO 60 ASRE 39 C------- ASSEMBLAGE DES REACTIONS EXTERNES ASRE 40 C MODIFIER LES TERMES DE KLOCE POUR ASSEMBLER SEULEMENT LES D.L. ASRE 41 C IMPOSES ASRE 42 DO 50 ID=1,IDLE ASRE 43 IF(KLOCE(ID)) 30,50,40 ASRE 44 30 KLOCE(ID)=-KLOCE(ID) ASRE 45 GO TO 50 ASRE 46 40 KLOCE(ID)=0 ASRE 47 50 CONTINUE ASRE 48 CALL ASSEL(0,1,IDLE,NSYM,KLOCE,KLD,VKE,VFE,VKGS,VKGD,VKGI,VREAC) ASRE 49 60 ITPE1=ITPE ASRE 50 RETURN ASRE 51 END ASRE 52 SUBROUTINE ELEMLB(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ELLB 1 C=======================================================================ELLB 2 C CALCUL DES GRANDEURS ELEMENTAIRES POUR TOUS LES TYPES D'ELEMENTS ELLB 3 C=======================================================================ELLB 4 IMPLICIT REAL*8(A-H,O-Z) ELLB 5 COMMON/RGDT/IEL,ITPE ELLB 6 DIMENSION VCORE(1),VPRNE(1),VPREE(1),VDLE(1),VKE(1),VFE(1) ELLB 7 C-----------------------------------------------------------------------ELLB 8 GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, 90,100),ITPE ELLB 9 C------- ELEMENT DE TYPE 1 ELLB 10 10 CALL ELEM01(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ELLB 11 GO TO 900 ELLB 12 C------- ELEMENT DE TYPE 2 ELLB 13 20 CALL ELEM02(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ELLB 14 GO TO 900 ELLB 15 C------- ELEMENT DE TYPE 3 ELLB 16 30 CALL ELEM03(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ELLB 17 GO TO 900 ELLB 18 C------- ELEMENT DE TYPE 4 ELLB 19 40 CALL ELEM04(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ELLB 20 GO TO 900 ELLB 21 C------- ELEMENT DE TYPE 5 ELLB 22 50 CALL ELEM05(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ELLB 23 GO TO 900 ELLB 24 C------- ELEMENT DE TYPE 6 ELLB 25 60 CALL ELEM06(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ELLB 26 GO TO 900 ELLB 27 C------- ELEMENT DE TYPE 7 ELLB 28 70 CALL ELEM07(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ELLB 29 GO TO 900 ELLB 30 C------- ELEMENT DE TYPE 8 ELLB 31 80 CALL ELEM08(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ELLB 32 GO TO 900 ELLB 33 C------- ELEMENT DE TYPE 9 ELLB 34 90 CALL ELEM09(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ELLB 35 GO TO 900 ELLB 36 C------- ELEMENT DE TYPE 10 ELLB 37 100 CALL ELEM10(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ELLB 38 GO TO 900 ELLB 39 C------- AUTRES ELEMENTS ELLB 40 C ........ ELLB 41 900 RETURN ELLB 42 END ELLB 43 SUBROUTINE ASSEL(IKG,IFG,IDLE,NSYM,KLOCE,KLD,VKE,VFE,VKGS, ASSE 1 1 VKGD,VKGI,VFG) ASSE 2 C=======================================================================ASSE 3 C ASSEMBLAGE D'UNE MATRICE ET/OU D'UN VECTEUR ELEMENTAIRE ASSE 4 C (MATRICE SYMETRIQUE OU NON) ASSE 5 C ENTREES ASSE 6 C IKG SI IKG.EQ.1 ASSEMBLAGE DE LA MATRICE ELEMENTAIRE KE ASSE 7 C IFG SI IFG.EQ.1 ASSEMBLAGE DU VECTEUR ELEMENTAIRE FE ASSE 8 C IDLE NOMBRE DE D.L. DE L'ELEMENT ASSE 9 C NSYM 0=PROBLEME SYMETRIQUE, 1=PROBLEME NON SYMETRIQUE ASSE 10 C KLOCE VECTEUR DE LOCALISATION DE L'ELEMENT ASSE 11 C KLD HAUTEURS CUMULEES DE COLONNES DE KG ASSE 12 C VKE MATRICE ELEMENTAIRE KE(PLEINE OU TRIANGLE SUPERIEUR ASSE 13 C PAR COLONNES DESCENDANTES) ASSE 14 C VFE VECTEUR ELEMENTAIRE FE ASSE 15 C SORTIES ASSE 16 C VKGS,VKGD,VKGI MATRICE GLOBALE (LIGNE DE CIEL) ASSE 17 C (SYMETRIQUE OU NON) ASSE 18 C VFG VECTEUR SOLLICITATIONS GLOBAL ASSE 19 C=======================================================================ASSE 20 IMPLICIT REAL*8(A-H,O-Z) ASSE 21 DIMENSION KLOCE(1),KLD(1),VKE(1),VFE(1),VKGS(1),VKGD(1), ASSE 22 1 VKGI(1),VFG(1) ASSE 23 C-----------------------------------------------------------------------ASSE 24 C ASSE 25 C------- ASSEMBLAGE DE LA MATRICE ELEMENTAIRE ASSE 26 C ASSE 27 IF(IKG.NE.1) GO TO 100 ASSE 28 IEQ0=IDLE ASSE 29 IEQ1=1 ASSE 30 C------- POUR CHAQUE COLONNE DE KE ASSE 31 DO 90 JD=1,IDLE ASSE 32 IF(NSYM.NE.1) IEQ0=JD ASSE 33 JL=KLOCE(JD) ASSE 34 IF(JL) 90,90,10 ASSE 35 10 I0=KLD(JL+1) ASSE 36 IEQ=IEQ1 ASSE 37 IQ=1 ASSE 38 C------- POUR CHAQUE LIGNE DE KE ASSE 39 DO 80 ID=1,IDLE ASSE 40 IL=KLOCE(ID) ASSE 41 IF(NSYM.EQ.1) GO TO 30 ASSE 42 IF(ID-JD) 30,20,20 ASSE 43 20 IQ=ID ASSE 44 30 IF(IL) 80,80,40 ASSE 45 40 IJ=JL-IL ASSE 46 IF(IJ) 70,50,60 ASSE 47 C------- TERMES DIAGONAUX DE KG ASSE 48 50 VKGD(IL)=VKGD(IL)+VKE(IEQ) ASSE 49 GO TO 80 ASSE 50 C------- TERMES DU TRIANGLE SUPERIEUR DE KG ASSE 51 60 I=I0-IJ ASSE 52 VKGS(I)=VKGS(I)+VKE(IEQ) ASSE 53 GO TO 80 ASSE 54 C------- TERMES DU TRIANGLE INFERIEUR DE KG ASSE 55 70 IF(NSYM.NE.1) GO TO 80 ASSE 56 I=KLD(IL+1)+IJ ASSE 57 VKGI(I)=VKGI(I)+VKE(IEQ) ASSE 58 80 IEQ=IEQ+IQ ASSE 59 90 IEQ1=IEQ1+IEQ0 ASSE 60 C ASSE 61 C------- ASSEMBLAGE DU VECTEUR ELEMENTAIRE ASSE 62 C ASSE 63 100 IF(IFG.NE.1) GO TO 130 ASSE 64 DO 120 ID=1,IDLE ASSE 65 IL=KLOCE(ID) ASSE 66 IF(IL) 120,120,110 ASSE 67 110 VFG(IL)=VFG(IL)+VFE(ID) ASSE 68 120 CONTINUE ASSE 69 130 RETURN ASSE 70 END ASSE 71 SUBROUTINE MODFG(IDLE,NSYM,KLOCE,VDIMP,VKE,VFG) MODF 1 C=======================================================================MODF 2 C MODIFICATION DU VECTEUR FG POUR TENIR COMPTE DES DEGRES DE LIBERTEMODF 3 C IMPOSES NON NULS CORRESPONDANT A UN ELEMENT MODF 4 C ENTREES MODF 5 C IDLE NOMBRE DE D.L. DE L'ELEMENT MODF 6 C NSYM 0=PROBLEME SYMETRIQUE, 1=PROBLEME NON SYMETRIQUE MODF 7 C KLOCE VECTEUR DE LOCALISATION DE L'ELEMENT MODF 8 C VDIMP VALEURS DES D.L. IMPOSES MODF 9 C VKE MATRICE ELEMENTAIRE (PLEINE OU TRIANGLE SUPERIEUR PARMODF 10 C COLONNES DESCENDANTES) MODF 11 C SORTIE MODF 12 C VFG VECTEUR SOLLICITATIONS GLOBAL MODF 13 C=======================================================================MODF 14 IMPLICIT REAL*8(A-H,O-Z) MODF 15 DIMENSION KLOCE(1),VDIMP(1),VKE(1),VFG(1) MODF 16 DATA ZERO/0.D0/ MODF 17 C-----------------------------------------------------------------------MODF 18 IEQ0=IDLE MODF 19 IEQ1=1 MODF 20 C------- POUR CHAQUE LIGNE DE LA MATRICE ELEMENTAIRE MODF 21 DO 50 JD=1,IDLE MODF 22 IF(NSYM.NE.1) IEQ0=JD MODF 23 IEQ=IEQ1 MODF 24 JL=KLOCE(JD) MODF 25 IQ=1 MODF 26 IF(JL) 10,50,50 MODF 27 10 JL=-JL MODF 28 DIMP=VDIMP(JL) MODF 29 IF(DIMP.EQ.ZERO) GO TO 50 MODF 30 C------- POUR CHAQUE COLONNE DE LA MATRICE ELEMENTAIRE MODF 31 DO 40 ID=1,IDLE MODF 32 IL=KLOCE(ID) MODF 33 IF(NSYM.EQ.1) GO TO 30 MODF 34 IF(ID-JD) 30,20,20 MODF 35 20 IQ=ID MODF 36 30 IF(IL.GT.0) VFG(IL)=VFG(IL)-VKE(IEQ)*DIMP MODF 37 40 IEQ=IEQ+IQ MODF 38 50 IEQ1=IEQ1+IEQ0 MODF 39 RETURN MODF 40 END MODF 41 SUBROUTINE PRPVTS(VKGD) PRPV 1 C=======================================================================PRPV 2 C CALCUL ET IMPRESSION DES PIVOTS ET DU DETERMINANT DE LA MATRICE KGPRPV 3 C=======================================================================PRPV 4 IMPLICIT REAL*8(A-H,O-Z) PRPV 5 COMMON/RESO/NEQ PRPV 6 COMMON/ES/M,MR,MP PRPV 7 DIMENSION VKGD(1) PRPV 8 DATA UN/1.D0/,GROS/1.D38/ PRPV 9 ABS(X)=DABS(X) PRPV 10 C-----------------------------------------------------------------------PRPV 11 X1=GROS PRPV 12 X2=GROS PRPV 13 DET=UN PRPV 14 IDET=0 PRPV 15 C------- IMPRESSION DES PIVOTS DE KG PRPV 16 IF(M.GE.2) WRITE(MP,2000)(VKGD(I),I=1,NEQ) PRPV 17 2000 FORMAT(/' PIVOTS DE LA MATRICE GLOBALE'/(1X,10E12.5)) PRPV 18 DO 50 I=1,NEQ PRPV 19 C------- PIVOT MINIMUM EN VALEUR ABSOLUE PRPV 20 X=ABS(VKGD(I)) PRPV 21 IF(X.GT.X1) GO TO 10 PRPV 22 X1=X PRPV 23 I1=I PRPV 24 C------- PIVOT MINIMUM EN VALEUR ALGEBRIQUE PRPV 25 X=VKGD(I) PRPV 26 10 IF(X.GT.X2) GO TO 20 PRPV 27 X2=X PRPV 28 I2=I PRPV 29 C------- DETERMINANT (LE LIMITER A 10 PUISSANCE + OU - 10) PRPV 30 20 DET=DET*VKGD(I) PRPV 31 30 DET1=ABS(DET) PRPV 32 IF(DET1.LT.1.D10) GO TO 40 PRPV 33 DET=DET*1.D-10 PRPV 34 IDET=IDET+10 PRPV 35 40 IF(DET1.GT.1.D-10) GO TO 50 PRPV 36 DET=DET*1.D10 PRPV 37 IDET=IDET-10 PRPV 38 GO TO 30 PRPV 39 50 CONTINUE PRPV 40 C------- IMPRESSIONS PRPV 41 WRITE(MP,2010) X1,I1,X2,I2,DET,IDET PRPV 42 2010 FORMAT(/15X,'PIVOT MINIMUM VALEUR ABSOLUE =',E12.5,' EQUATION:',PRPV 43 1 I5 /29X, 'VALEUR ALGEBRIQUE=',E12.5,' EQUATION:',PRPV 44 2 I5 /29X, 'DETERMINANT =',E12.5,' * 10 ** ', PRPV 45 3 I5/) PRPV 46 RETURN PRPV 47 END PRPV 48 SUBROUTINE PRRESD(VKGS,VKGD,VKGI,VFG,KLD,VRES) PRRE 1 C=======================================================================PRRE 2 C CALCUL ET IMPRESSION DES RESIDUS DE RESOLUTION K.U - F PRRE 3 C=======================================================================PRRE 4 IMPLICIT REAL*8(A-H,O-Z) PRRE 5 COMMON/ASSE/NSYM,NKG PRRE 6 COMMON/RESO/NEQ,NRES,MRES PRRE 7 COMMON/ES/M,MR,MP,M1,M2,M3 PRRE 8 DIMENSION VKGS(1),VKGD(1),VKGI(1),VFG(1),KLD(1),VRES(1) PRRE 9 DATA ZERO/0.D0/ PRRE 10 ABS(X)=DABS(X) PRRE 11 C-----------------------------------------------------------------------PRRE 12 REWIND M3 PRRE 13 C------- SAUTER LE VECTEUR FG NON MODIFIE PAR LES C.L. SUR FICHIER M3 PRRE 14 READ(M3) (VRES(I),I=1,NEQ) PRRE 15 C------- LIRE LE VECTEUR MODIFIE PAR LES C.L. ET LA MATRICE KG PRRE 16 READ(M3) (VRES(I),I=1,NEQ) PRRE 17 READ(M3) (VKGS(I),I=1,NKG),(VKGD(I),I=1,NEQ) PRRE 18 IF(NSYM.EQ.1) READ(M3) (VKGI(I),I=1,NKG) PRRE 19 C------- CALCULER LE RESIDU DE RESOLUTION PRRE 20 DO 10 I=1,NEQ PRRE 21 10 VRES(I)=-VRES(I) PRRE 22 CALL MULKU(VKGS,VKGD,VKGI,KLD,VFG,NEQ,NSYM,VRES) PRRE 23 DO 20 I=1,NEQ PRRE 24 20 VRES(I)=-VRES(I) PRRE 25 X1=ZERO PRRE 26 DO 30 I=1,NEQ PRRE 27 X=ABS(VRES(I)) PRRE 28 IF(X1.GE.X) GO TO 30 PRRE 29 X1=X PRRE 30 I1=I PRRE 31 30 CONTINUE PRRE 32 IF(M.GE.2) WRITE(MP,2000) (VRES(I),I=1,NEQ) PRRE 33 2000 FORMAT(/' RESIDUS DE RESOLUTION'/(1X,10E12.5)) PRRE 34 WRITE(MP,2010) X1,I1 PRRE 35 2010 FORMAT(/' RESIDU DE RESOLUTION MAX.=',E12.5,' EQUATION',I5) PRRE 36 RETURN PRRE 37 END PRRE 38 SUBROUTINE PRSOL(KDLNC,VCORG,VDIMP,KNEQ,VFG) PRSO 1 C=======================================================================PRSO 2 C IMPRESSION DE LA SOLUTION PRSO 3 C=======================================================================PRSO 4 IMPLICIT REAL*8(A-H,O-Z) PRSO 5 COMMON/COOR/NDIM,NNT PRSO 6 COMMON/ES/M,MR,MP PRSO 7 COMMON/TRVL/V(10),FX(10) PRSO 8 DIMENSION VDIMP(1),KDLNC(1),VCORG(1),KNEQ(1),VFG(1) PRSO 9 DATA RF/4H * /,RL/4H /,ZERO/0.D0/ PRSO 10 C-----------------------------------------------------------------------PRSO 11 X2=ZERO PRSO 12 X3=ZERO PRSO 13 WRITE(MP,2000) PRSO 14 2000 FORMAT(/' NOEUDS',4X,'X',11X,'Y',11X,'Z',10X,'DEGRES DE LIBERTE (*PRSO 15 1 = IMPOSE)'/) PRSO 16 I2=0 PRSO 17 DO 50 IN=1,NNT PRSO 18 I1=I2+1 PRSO 19 I2=I2+NDIM PRSO 20 ID1=KDLNC(IN)+1 PRSO 21 ID2=KDLNC(IN+1) PRSO 22 ID=ID2-ID1+1 PRSO 23 IF(ID2.LT.ID1) GO TO 50 PRSO 24 X1=VCORG(I1) PRSO 25 IF(NDIM.GE.2) X2=VCORG(I1+1) PRSO 26 IF(NDIM.GE.3) X3=VCORG(I1+2) PRSO 27 J=ID1 PRSO 28 DO 40 I=1,ID PRSO 29 JJ=KNEQ(J) PRSO 30 IF(JJ) 10,20,30 PRSO 31 10 V(I)=VDIMP(-JJ) PRSO 32 FX(I)=RF PRSO 33 GO TO 40 PRSO 34 20 V(I)=ZERO PRSO 35 FX(I)=RF PRSO 36 GO TO 40 PRSO 37 30 V(I)=VFG(JJ) PRSO 38 FX(I)=RL PRSO 39 40 J=J+1 PRSO 40 WRITE(MP,2010)IN,X1,X2,X3,(V(II),FX(II),II=1,ID) PRSO 41 2010 FORMAT(1X,I5,3E12.5,5X,5(E12.5,A4)/47X,5(E12.5,A4)) PRSO 42 50 CONTINUE PRSO 43 RETURN PRSO 44 END PRSO 45 SUBROUTINE DLELM(KLOCE,VDLG,VDIMP,VDLE) DLEL 1 C=======================================================================DLEL 2 C EXTRACTION DES D.L. D'UN ELEMENT DLEL 3 C=======================================================================DLEL 4 IMPLICIT REAL*8(A-H,O-Z) DLEL 5 COMMON/RGDT/IEL,INUL(3),IDLE DLEL 6 COMMON/ES/M,MR,MP DLEL 7 DIMENSION KLOCE(1),VDLG(1),VDIMP(1),VDLE(1) DLEL 8 DATA ZERO/0.D0/ DLEL 9 C-----------------------------------------------------------------------DLEL 10 DO 40 ID=1,IDLE DLEL 11 IL=KLOCE(ID) DLEL 12 IF(IL) 10,20,30 DLEL 13 10 VDLE(ID)=VDIMP(-IL) DLEL 14 GO TO 40 DLEL 15 20 VDLE(ID)=ZERO DLEL 16 GO TO 40 DLEL 17 30 VDLE(ID)=VDLG(IL) DLEL 18 40 CONTINUE DLEL 19 IF(M.GE.2) WRITE(MP,2000) IEL,(VDLE(ID),ID=1,IDLE) DLEL 20 2000 FORMAT(' DEGRES DE LIBERTE DE L ELEMENT ',I5/(1X,10E12.5)) DLEL 21 RETURN DLEL 22 END DLEL 23 SUBROUTINE MULKU(VKGS,VKGD,VKGI,KLD,VFG,NEQ,NSYM,VRES) MULK 1 C=======================================================================MULK 2 C CE SOUS-PROGRAMME AJOUTE AU VECTEUR RES LE PRODUIT DE LA MULK 3 C MATRICE KG PAR LE VECTEUR FG MULK 4 C ENTREES MULK 5 C VKGS,VKGD,VKGI MATRICE KG STOCKEE PAR LIGNE DE CIEL (SYM. MULK 6 C OU NON SYM.) MULK 7 C KLD TABLE DES POINTEURS DES HAUTS DE COLONNES DE KG MULK 8 C VFG VECTEUR FG MULK 9 C NEQ DIMENSION DES VECTEURS FG ET RES MULK 10 C NSYM .EQ.1 SI LE PROBLEME N'EST PAS SYMETRIQUE MULK 11 C VRES VECTEUR RES MULK 12 C SORTIE MULK 13 C VRES VECTEUR RES MULK 14 C=======================================================================MULK 15 IMPLICIT REAL*8(A-H,O-Z) MULK 16 DIMENSION VKGS(1),VKGD(1),VKGI(1),KLD(1),VFG(1),VRES(1) MULK 17 C-----------------------------------------------------------------------MULK 18 C------- POUR CHAQUE COLONNE DE LA MATRICE KG MULK 19 DO 20 IK=1,NEQ MULK 20 JHK=KLD(IK) MULK 21 JHK1=KLD(IK+1) MULK 22 LHK=JHK1-JHK MULK 23 C------- TERME DIAGONAL MULK 24 C=VKGD(IK)*VFG(IK) MULK 25 IF(LHK.LE.0) GO TO 20 MULK 26 I0=IK-LHK MULK 27 C------- TERMES DE LIGNE MULK 28 IF(NSYM.NE.1) C=C+SCAL(VKGS(JHK),VFG(I0),LHK) MULK 29 IF(NSYM.EQ.1) C=C+SCAL(VKGI(JHK),VFG(I0),LHK) MULK 30 C------- TERMES DE COLONNE MULK 31 J=JHK MULK 32 I1=IK-1 MULK 33 DO 10 IJ=I0,I1 MULK 34 VRES(IJ)=VRES(IJ)+VKGS(J)*VFG(IK) MULK 35 10 J=J+1 MULK 36 20 VRES(IK)=VRES(IK)+C MULK 37 RETURN MULK 38 END MULK 39 C++++++ FIN FIGURE 6.22 C++++++ DEBUT FIGURE 5.10 SUBROUTINE GAUSS(IPGKED,NDIM,VKPG,VCPG,IPG) GAUS 1 C=======================================================================GAUS 2 C CREE LES TABLES DE COORDONNEES ET DE POIDS DES POINTS DE GAUSS GAUS 3 C (1,2 ET 3 DIMENSIONS)(1,2,3 OU 4 P.G. PAR DIMENSION) GAUS 4 C ENTREES GAUS 5 C IPGKED NOMBRE DE POINTS DANS LES DIRECTIONS KSI,ETA,DZETA GAUS 6 C NDIM NOMBRE DE DIMENSIONS (1,2 OU 3) GAUS 7 C SORTIES GAUS 8 C VKPG COORDONNEES DES POINTS DE GAUSS GAUS 9 C VCPG POIDS DES POINTS DE GAUSS GAUS 10 C IPG NOMBRE TOTAL DE POINTS DE GAUSS GAUS 11 C=======================================================================GAUS 12 IMPLICIT REAL*8(A-H,O-Z) GAUS 13 DIMENSION IPGKED(1),VKPG(1),VCPG(1),G(10),P(10),INDIC(4) GAUS 14 DATA INDIC/1,2,4,7/ GAUS 15 DATA G/0.0D0,-.577350269189626D0,.577350269189626D0, GAUS 16 1 -.774596669241483D0,0.0D0,.774596669241483D0, GAUS 17 2 -.861136311594050D0,-.339981043584860D0, GAUS 18 3 .339981043584860D0,.861136311594050D0/ GAUS 19 DATA P/2.0D0,1.0D0,1.0D0, GAUS 20 1 0.555555555555556D0,0.888888888888889D0,0.555555555555556D0,GAUS 21 2 .347854845137450D0,.652145154862550D0, GAUS 22 3 .652145154862550D0,.347854845137450D0/ GAUS 23 C-----------------------------------------------------------------------GAUS 24 II=IPGKED(1) GAUS 25 IMIN=INDIC(II) GAUS 26 IMAX=IMIN+II-1 GAUS 27 IF(NDIM-2) 10,20,30 GAUS 28 C------- 1 DIMENSION GAUS 29 10 IPG=0 GAUS 30 DO 15 I=IMIN,IMAX GAUS 31 IPG=IPG+1 GAUS 32 VKPG(IPG)=G(I) GAUS 33 15 VCPG(IPG)=P(I) GAUS 34 RETURN GAUS 35 C------- 2 DIMENSIONS GAUS 36 20 II=IPGKED(2) GAUS 37 JMIN=INDIC(II) GAUS 38 JMAX=JMIN+II-1 GAUS 39 IPG=0 GAUS 40 L=1 GAUS 41 DO 25 I=IMIN,IMAX GAUS 42 DO 25 J=JMIN,JMAX GAUS 43 IPG=IPG+1 GAUS 44 VKPG(L)=G(I) GAUS 45 VKPG(L+1)=G(J) GAUS 46 L=L+2 GAUS 47 25 VCPG(IPG)=P(I)*P(J) GAUS 48 RETURN GAUS 49 C------- 3 DIMENSIONS GAUS 50 30 II=IPGKED(2) GAUS 51 JMIN=INDIC(II) GAUS 52 JMAX=JMIN+II-1 GAUS 53 II=IPGKED(3) GAUS 54 KMIN=INDIC(II) GAUS 55 KMAX=KMIN+II-1 GAUS 56 IPG=0 GAUS 57 L=1 GAUS 58 DO 35 I=IMIN,IMAX GAUS 59 DO 35 J=JMIN,JMAX GAUS 60 DO 35 K=KMIN,KMAX GAUS 61 IPG=IPG+1 GAUS 62 VKPG(L)=G(I) GAUS 63 VKPG(L+1)=G(J) GAUS 64 VKPG(L+2)=G(K) GAUS 65 L=L+3 GAUS 66 35 VCPG(IPG)=P(I)*P(J)*P(K) GAUS 67 RETURN GAUS 68 END GAUS 69 C++++++ FIN FIGURE 5.10 C++++++ DEBUT FIGURE 1.6 SUBROUTINE PNINV(VKSI,KEXP,VP,K1,VPN) PNIN 1 C=======================================================================PNIN 2 C CALCUL DE LA MATRICE PN INVERSE CONTENANT LES COEFFICIENTS PNIN 3 C DES FONCTIONS N PNIN 4 C ENTREES VKSI,KEXP,INEL,IDLE,ITPE,M,MP PNIN 5 C TRAVAIL VP,K1 PNIN 6 C SORTIE VPN PNIN 7 C=======================================================================PNIN 8 IMPLICIT REAL*8(A-H,O-Z) PNIN 9 COMMON/COOR/NDIM PNIN 10 COMMON/RGDT/IEL,ITPE,ITPE1,IGRE,IDLE,ICE,IPRNE,IPREE,INEL,IDEG,IPGPNIN 11 COMMON/ES/M,MR,MP PNIN 12 DIMENSION VKSI(1),KEXP(1),VP(1),K1(1),VPN(1),KDER(3) PNIN 13 DATA ZERO/0.D0/,KDER/3*0/ PNIN 14 C-----------------------------------------------------------------------PNIN 15 C PNIN 16 C....... CONSTRUCTION DE LA MATRICE PN (VALABLE POUR TOUT ELEMENT DE PNIN 17 C TYPE LAGRANGE) PNIN 18 C PNIN 19 I0=1 PNIN 20 I1=1 PNIN 21 DO 20 IN=1,INEL PNIN 22 CALL BASEP(VKSI(I1),KEXP,KDER,VP) PNIN 23 I2=I0 PNIN 24 DO 10 IJ=1,INEL PNIN 25 VPN(I2)=VP(IJ) PNIN 26 10 I2=I2+INEL PNIN 27 I0=I0+1 PNIN 28 20 I1=I1+NDIM PNIN 29 C PNIN 30 C....... FIN DE LA CONSTRUCTION DE PN PNIN 31 C PNIN 32 C------- IMPRESSION DE PN PNIN 33 IF(M.LT.4) GO TO 40 PNIN 34 WRITE(MP,2000) PNIN 35 2000 FORMAT(/' MATRICE PN'/) PNIN 36 ID=(INEL-1)*INEL PNIN 37 DO 30 I0=1,INEL PNIN 38 I1=I0+ID PNIN 39 30 WRITE(MP,2010) (VPN(IJ),IJ=I0,I1,INEL) PNIN 40 2010 FORMAT(1X,10E13.5/(14X,9E13.5)) PNIN 41 C------- INVERSION DE PN PNIN 42 40 CALL INVERS(VPN,INEL,INEL,K1,DET) PNIN 43 IF(DET.NE.ZERO) GO TO 50 PNIN 44 WRITE(MP,2020) ITPE PNIN 45 2020 FORMAT(' *** ERREUR, PN SINGULIERE, ELEMENT DE TYPE:',I3) PNIN 46 STOP PNIN 47 C------- IMPRESSION DE PN INVERSE PNIN 48 50 IF(M.LT.4) GO TO 70 PNIN 49 WRITE(MP,2030) PNIN 50 2030 FORMAT(/' MATRICE PN INVERSE'/) PNIN 51 DO 60 I0=1,INEL PNIN 52 I1=I0+ID PNIN 53 60 WRITE(MP,2010) (VPN(IJ),IJ=I0,I1,INEL) PNIN 54 70 RETURN PNIN 55 END PNIN 56 SUBROUTINE NI(VKSI,KEXP,KDER,VP,VPN,VNI) NI 1 C=======================================================================NI 2 C CALCUL DES FONCTIONS N OU DE LEURS DERIVEES AU POINT DE NI 3 C COORDONNES VKSI SUR L'ELEMENT DE REFERENCE NI 4 C ENTREES VKSI,KEXP,KDER,VP,VPN,IDLE,M,MP NI 5 C SORTIE VNI NI 6 C=======================================================================NI 7 IMPLICIT REAL*8(A-H,O-Z) NI 8 COMMON/COOR/NDIM NI 9 COMMON/RGDT/IEL,ITPE,ITPE1,IGRE,IDLE,ICE,IPRNE,IPREE,INEL,IDEG,IPGNI 10 COMMON/ES/M,MR,MP NI 11 DIMENSION VKSI(1),KEXP(1),KDER(1),VP(1),VPN(1),VNI(1) NI 12 DATA ZERO/0.D0/ NI 13 C-----------------------------------------------------------------------NI 14 C------- CALCUL DE LA BASE POLYNOMIALE AU POINT VKSI NI 15 CALL BASEP(VKSI,KEXP,KDER,VP) NI 16 C------- PRODUIT P*PN INVERSE NI 17 I0=1 NI 18 DO 20 IJ=1,INEL NI 19 I1=I0 NI 20 C=ZERO NI 21 DO 10 II=1,INEL NI 22 C=C+VP(II)*VPN(I1) NI 23 10 I1=I1+1 NI 24 VNI(IJ)=C NI 25 20 I0=I0+INEL NI 26 C------- IMPRESSION DES FONCTIONS N NI 27 IF(M.LT.3) GO TO 30 NI 28 WRITE(MP,2000) (KDER(I),I=1,NDIM) NI 29 2000 FORMAT(/' DERIVEE DE N D ORDRE ',3I2) NI 30 WRITE(MP,2010) (VKSI(I),I=1,NDIM) NI 31 2010 FORMAT(14X,'AU POINT ',3E13.5) NI 32 WRITE(MP,2020) (VNI(I),I=1,INEL) NI 33 2020 FORMAT(/(1X,10E13.5)) NI 34 30 RETURN NI 35 END NI 36 SUBROUTINE BASEP(VKSI,KEXP,KDER,VP) BASE 1 C=======================================================================BASE 2 C CALCUL D'UNE BASE POLYNOMIALE ET DE SES DERIVEES AU POINT VKSI BASE 3 C ENTREES VKSI,KEXP,KDER,IDLE,IDEG,NDIM,M,MP BASE 4 C SORTIE VP BASE 5 C=======================================================================BASE 6 IMPLICIT REAL*8(A-H,O-Z) BASE 7 COMMON/COOR/NDIM BASE 8 COMMON/RGDT/IEL,ITPE,ITPE1,IGRE,IDLE,ICE,IPRNE,IPREE,INEL,IDEG,IPGBASE 9 COMMON/ES/M,MR,MP BASE 10 DIMENSION VKSI(1),KEXP(1),KDER(1),VP(1) BASE 11 DIMENSION PUISS(3,10) BASE 12 DATA ZERO/0.D0/,UN/1.D0/ BASE 13 C-----------------------------------------------------------------------BASE 14 C------- CALCUL DES PUISSANCES SUCCESSIVES DE KSI,ETA,DZETA BASE 15 DO 10 I=1,NDIM BASE 16 PUISS(I,1)=UN BASE 17 DO 10 ID=1,IDEG BASE 18 10 PUISS(I,ID+1)=PUISS(I,ID)*VKSI(I) BASE 19 C------- DERIVEES D ORDRE KDER EN KSI,ETA,DZETA BASE 20 DO 50 IDL=1,INEL BASE 21 C1=UN BASE 22 I0=(IDL-1)*NDIM BASE 23 DO 30 I=1,NDIM BASE 24 IDR=KDER(I) BASE 25 I0=I0+1 BASE 26 IXP=KEXP(I0)+1 BASE 27 J=IXP-IDR BASE 28 IF(J.LE.0) GO TO 40 BASE 29 IF(IDR.LE.0) GO TO 30 BASE 30 DO 20 ID=1,IDR BASE 31 20 C1=C1*(IXP-ID) BASE 32 30 C1=C1*PUISS(I,J) BASE 33 GO TO 50 BASE 34 40 C1=ZERO BASE 35 50 VP(IDL)=C1 BASE 36 C------- IMPRESSION DE LA BASE POLYNOMIALE BASE 37 IF(M.LT.4) GO TO 60 BASE 38 WRITE(MP,2000) (KDER(I),I=1,NDIM) BASE 39 2000 FORMAT(/' BASE POLYNOMIALE, DERIVEE D ORDRE ',3I2) BASE 40 WRITE(MP,2010) (VKSI(I),I=1,NDIM) BASE 41 2010 FORMAT(19X,'AU POINT ',3E13.5) BASE 42 WRITE(MP,2020) (VP(I),I=1,INEL) BASE 43 2020 FORMAT(/(1X,10E12.5)) BASE 44 60 RETURN BASE 45 END BASE 46 SUBROUTINE INVERS(VP,N,IVP,K,DET) INVE 1 C=======================================================================INVE 2 C INVERSION D'UNE MATRICE NON SYMETRIQUE AVEC RECHERCHE DE PIVOT INVE 3 C NON NUL SUR UNE COLONNE INVE 4 C ENTREES INVE 5 C VP MATRICE A INVERSER INVE 6 C N ORDRE DE LA MATRICE A INVERSER INVE 7 C IVP DIMENSION DE LA MATRICE DANS LE PROGRAMME D'APPEL INVE 8 C K VECTEUR DE TRAVAIL ENTIER DE LONGUEUR N INVE 9 C SORTIES INVE 10 C VP MATRICE INVERSEE INVE 11 C DET DETERMINANT INVE 12 C=======================================================================INVE 13 IMPLICIT REAL*8(A-H,O-Z) INVE 14 DIMENSION VP(IVP,IVP),K(N) INVE 15 DATA ZERO/0.D0/,UN/1.D0/,EPS/1.D-13/ INVE 16 ABS(X)=DABS(X) INVE 17 C-----------------------------------------------------------------------INVE 18 DET=UN INVE 19 DO 5 I=1,N INVE 20 5 K(I)=I INVE 21 C------- DEBUT DE L'INVERSION INVE 22 DO 80 II=1,N INVE 23 C------- RECHERCHE D'UN PIVOT NON NUL SUR LA COLONNE II INVE 24 DO 10 I=II,N INVE 25 PIV=VP(I,II) INVE 26 IF(ABS(PIV).GT.EPS) GO TO 20 INVE 27 10 CONTINUE INVE 28 DET=ZERO INVE 29 RETURN INVE 30 C------- ECHANGER LA LIGNE II ET LA LIGNE I INVE 31 20 DET=DET*PIV INVE 32 IF(I.EQ.II) GO TO 40 INVE 33 I1=K(II) INVE 34 K(II)=K(I) INVE 35 K(I)=I1 INVE 36 DO 30 J=1,N INVE 37 C=VP(I,J) INVE 38 VP(I,J)=VP(II,J) INVE 39 30 VP(II,J)=C INVE 40 DET=-DET INVE 41 C------- NORMALISER LA LIGNE DU PIVOT INVE 42 40 C=UN/PIV INVE 43 VP(II,II)=UN INVE 44 DO 50 J=1,N INVE 45 50 VP(II,J)=VP(II,J)*C INVE 46 C------- ELIMINATION INVE 47 DO 70 I=1,N INVE 48 IF(I.EQ.II) GO TO 70 INVE 49 C=VP(I,II) INVE 50 VP(I,II)=ZERO INVE 51 DO 60 J=1,N INVE 52 60 VP(I,J)=VP(I,J)-C*VP(II,J) INVE 53 70 CONTINUE INVE 54 80 CONTINUE INVE 55 C------- REORDONNER LES COLONNES DE L'INVERSE INVE 56 DO 120 J=1,N INVE 57 C------- CHERCHER J1 TEL QUE K(J1)=J INVE 58 DO 90 J1=J,N INVE 59 JJ=K(J1) INVE 60 IF(JJ.EQ.J) GO TO 100 INVE 61 90 CONTINUE INVE 62 100 IF(J.EQ.J1) GO TO 120 INVE 63 C------- ECHANGER LES COLONNES J ET J1 INVE 64 K(J1)=K(J) INVE 65 DO 110 I=1,N INVE 66 C=VP(I,J) INVE 67 VP(I,J)=VP(I,J1) INVE 68 110 VP(I,J1)=C INVE 69 120 CONTINUE INVE 70 RETURN INVE 71 END INVE 72 C++++++ FIN FIGURE 1.6 C++++++ DEBUT FIGURE 1.9 SUBROUTINE JACOB(VNI,VCORE,NDIM,INEL,VJ,VJ1,DETJ) JACB 1 C=======================================================================JACB 2 C CALCUL DE LA MATRICE JACOBIENNE ,DE SON DETERMINANT,DE SON INVERSEJACB 3 C (1,2,3 DIMENSIONS) JACB 4 C ENTREES JACB 5 C VNI DERIVEES DES FONCTIONS D'INTERPOLATION EN KSI,ETA, JACB 6 C DZETA JACB 7 C VCORE COORDONNEES DES NOEUDS DE L'ELEMENT JACB 8 C NDIM NOMBRE DE DIMENSIONS (1,2 OU 3) JACB 9 C INEL NOMBRE DE NOEUDS DE L'ELEMENT JACB 10 C SORTIES JACB 11 C VJ MATRICE JACOBIENNE JACB 12 C VJ1 MATRICE JACOBIENNE INVERSE JACB 13 C DETJ DETERMINANT DE LA MATRICE JACOBIENNE JACB 14 C=======================================================================JACB 15 IMPLICIT REAL*8(A-H,O-Z) JACB 16 DIMENSION VNI(INEL,1),VCORE(NDIM,1),VJ(1),VJ1(1) JACB 17 DATA ZERO/0.D0/,UN/1.D0/ JACB 18 C-----------------------------------------------------------------------JACB 19 C------- CONSTRUCTION DE LA MATRICE JACOBIENNE JACB 20 J=1 JACB 21 DO 20 JJ=1,NDIM JACB 22 DO 20 II=1,NDIM JACB 23 C=ZERO JACB 24 DO 10 IJ=1,INEL JACB 25 10 C=C+VNI(IJ,II)*VCORE(JJ,IJ) JACB 26 VJ(J)=C JACB 27 20 J=J+1 JACB 28 C------- INVERSION A 1,2 OU 3 DIMENSIONS JACB 29 GO TO (40,50,60),NDIM JACB 30 40 DETJ=VJ(1) JACB 31 IF(DETJ.EQ.ZERO) RETURN JACB 32 VJ1(1)=UN/DETJ JACB 33 RETURN JACB 34 50 DETJ=VJ(1)*VJ(4)-VJ(2)*VJ(3) JACB 35 IF(DETJ.EQ.ZERO) RETURN JACB 36 VJ1(1)=VJ(4)/DETJ JACB 37 VJ1(2)=-VJ(2)/DETJ JACB 38 VJ1(3)=-VJ(3)/DETJ JACB 39 VJ1(4)=VJ(1)/DETJ JACB 40 RETURN JACB 41 60 DETJ=VJ(1)*(VJ(5)*VJ(9)-VJ(8)*VJ(6)) JACB 42 1 +VJ(4)*(VJ(8)*VJ(3)-VJ(2)*VJ(9)) JACB 43 2 +VJ(7)*(VJ(2)*VJ(6)-VJ(5)*VJ(3)) JACB 44 IF(DETJ.EQ.ZERO) RETURN JACB 45 VJ1(1)=(VJ(5)*VJ(9)-VJ(6)*VJ(8))/DETJ JACB 46 VJ1(2)=(VJ(3)*VJ(8)-VJ(2)*VJ(9))/DETJ JACB 47 VJ1(3)=(VJ(2)*VJ(6)-VJ(3)*VJ(5))/DETJ JACB 48 VJ1(4)=(VJ(7)*VJ(6)-VJ(4)*VJ(9))/DETJ JACB 49 VJ1(5)=(VJ(1)*VJ(9)-VJ(7)*VJ(3))/DETJ JACB 50 VJ1(6)=(VJ(4)*VJ(3)-VJ(6)*VJ(1))/DETJ JACB 51 VJ1(7)=(VJ(4)*VJ(8)-VJ(7)*VJ(5))/DETJ JACB 52 VJ1(8)=(VJ(2)*VJ(7)-VJ(8)*VJ(1))/DETJ JACB 53 VJ1(9)=(VJ(1)*VJ(5)-VJ(4)*VJ(2))/DETJ JACB 54 RETURN JACB 55 END JACB 56 C++++++ FIN FIGURE 1.9 C++++++ DEBUT FIGURE 1.10 SUBROUTINE DNIDX(VNI,VJ1,NDIM,INEL,VNIX) DNID 1 C=======================================================================DNID 2 C CALCUL DES DERIVEES DES FONCTIONS D'INTERPOLATION PAR RAPPORT DNID 3 C A X,Y,Z DNID 4 C (1,2 OU 3 DIMENSIONS) DNID 5 C ENTREES DNID 6 C VNI DERIVEES DES FONCTIONS D'INTERPOLATION EN KSI,ETA, DNID 7 C DZETA DNID 8 C VJ1 INVERSE DU JACOBIEN DNID 9 C NDIM NOMBRE DE DIMENSIONS (1,2 OU 3) DNID 10 C INEL NOMBRE DE FONCTIONS D'INTERPOLATION (DE NOEUDS) DNID 11 C SORTIE DNID 12 C VNIX DERIVEES DES FONCTIONS D'INTERPOLATION EN X,Y,Z DNID 13 C=======================================================================DNID 14 IMPLICIT REAL*8(A-H,O-Z) DNID 15 DIMENSION VNI(INEL,1),VJ1(NDIM,1),VNIX(INEL,1) DNID 16 DATA ZERO/0.D0/ DNID 17 C-----------------------------------------------------------------------DNID 18 DO 20 I=1,NDIM DNID 19 DO 20 J=1,INEL DNID 20 C=ZERO DNID 21 DO 10 IJ=1,NDIM DNID 22 10 C=C+VJ1(I,IJ)*VNI(J,IJ) DNID 23 20 VNIX(J,I)=C DNID 24 RETURN DNID 25 END DNID 26 C++++++ FIN FIGURE 1.10 C++++++ DEBUT FIGURE 5.15 SUBROUTINE SOL(VKGS,VKGD,VKGI,VFG,KLD,NEQ,MP,IFAC,ISOL,NSYM,ENERG)SOL 1 C=======================================================================SOL 2 C RESOLUTION D'UN SYSTEME LINEAIRE SYMETRIQUE OU NON. LA MATRICE ESTSOL 3 C STOCKEE PAR LIGNE DE CIEL,EN MEMOIRE DANS LES TABLES SOL 4 C VKGS,VKGD,VKGI SOL 5 C ENTREES SOL 6 C VKGS,VKGD,VKGI MATRICE DU SYSTEME : PARTIES SUPERIEURE, SOL 7 C DIAGONALE, INFERIEURE SOL 8 C VFG SECOND MEMBRE SOL 9 C KLD POINTEURS VERS LES HAUTS DE COLONNE SOL 10 C NEQ NOMBRE D'EQUATIONS SOL 11 C MP UNITE LOGIQUE D'IMPRESSION SOL 12 C IFAC SI IFAC.EQ.1 TRIANGULARISATION DE SOL 13 C LA MATRICE SOL 14 C ISOL SI ISOL.EQ.1 CALCUL DE LA SOLUTION A SOL 15 C PARTIR DE LA MATRICE TRIANGULARISEE SOL 16 C NSYM INDICE DE PROBLEME NON SYMETRIQUE SOL 17 C SORTIES SOL 18 C VKGS,VKGD,VKGI MATRICE TRIANGULARISEE (SI IFAC.EQ.1) SOL 19 C VFG SOLUTION (SI ISOL.EQ.1) SOL 20 C ENERG ENERGIE DU SYSTEME (SI NSYM.EQ.0) SOL 21 C=======================================================================SOL 22 IMPLICIT REAL*8 (A-H,O-Z) SOL 23 DIMENSION VKGS(1),VKGD(1),VKGI(1),VFG(1),KLD(1) SOL 24 DATA ZERO/0.0D0/ SOL 25 C-----------------------------------------------------------------------SOL 26 IK=1 SOL 27 IF(VKGD(1).NE.ZERO) GO TO 10 SOL 28 WRITE(MP,2000) IK SOL 29 STOP SOL 30 10 ENERG=ZERO SOL 31 C SOL 32 C----- POUR CHAQUE COLONNE IK A MODIFIER SOL 33 C SOL 34 JHK=1 SOL 35 DO 100 IK=2,NEQ SOL 36 C----- POINTEUR DU HAUT DE LA COLONNE SUIVANTE IK+1 SOL 37 JHK1=KLD(IK+1) SOL 38 C----- HAUTEUR DE LA COLONNE IK (HORS TERMES SUPERIEUR ET DIAGONAL) SOL 39 LHK=JHK1-JHK SOL 40 LHK1=LHK-1 SOL 41 C----- LIGNE DU PREMIER TERME A MODIFIER DANS LA COLONNE IK SOL 42 IMIN=IK-LHK1 SOL 43 IMIN1=IMIN-1 SOL 44 C------- LIGNE DU DERNIER TERME A MODIFIER DANS LA COLONNE IK SOL 45 IMAX=IK-1 SOL 46 IF(LHK1.LT.0) GO TO 100 SOL 47 IF(IFAC.NE.1) GO TO 90 SOL 48 IF(NSYM.EQ.1) VKGI(JHK)=VKGI(JHK)/VKGD(IMIN1) SOL 49 IF(LHK1.EQ.0) GO TO 40 SOL 50 C SOL 51 C----- MODIFIER LES TERMES NON DIAGONAUX DE LA COLONNE IK SOL 52 C SOL 53 JCK=JHK+1 SOL 54 JHJ=KLD(IMIN) SOL 55 C----- POUR CHAQUE TERME PLACE EN JCK, CORRESPONDANT A LA COLONNE IJ SOL 56 DO 30 IJ=IMIN,IMAX SOL 57 JHJ1=KLD(IJ+1) SOL 58 C----- NOMBRE DE TERMES MODIFICATIFS DU TERME PLACE EN JCK SOL 59 IC=MIN0(JCK-JHK,JHJ1-JHJ) SOL 60 IF(IC.LE.0.AND.NSYM.EQ.0) GO TO 20 SOL 61 C1=ZERO SOL 62 IF(IC.LE.0) GO TO 17 SOL 63 J1=JHJ1-IC SOL 64 J2=JCK-IC SOL 65 IF(NSYM.EQ.1) GO TO 15 SOL 66 VKGS(JCK)=VKGS(JCK)-SCAL(VKGS(J1),VKGS(J2),IC) SOL 67 GO TO 20 SOL 68 15 VKGS(JCK)=VKGS(JCK)-SCAL(VKGI(J1),VKGS(J2),IC) SOL 69 C1=SCAL(VKGS(J1),VKGI(J2),IC) SOL 70 17 VKGI(JCK)=(VKGI(JCK)-C1)/VKGD(IJ) SOL 71 20 JCK=JCK+1 SOL 72 30 JHJ=JHJ1 SOL 73 C SOL 74 C----- MODIFIER LE TERME DIAGONAL SOL 75 C SOL 76 40 JCK=JHK SOL 77 CDIAG=ZERO SOL 78 DO 70 IJ=IMIN1,IMAX SOL 79 C1=VKGS(JCK) SOL 80 IF(NSYM.EQ.1) GO TO 50 SOL 81 C2=C1/VKGD(IJ) SOL 82 VKGS(JCK)=C2 SOL 83 GO TO 60 SOL 84 50 C2=VKGI(JCK) SOL 85 60 CDIAG=CDIAG+C1*C2 SOL 86 70 JCK=JCK+1 SOL 87 VKGD(IK)=VKGD(IK)-CDIAG SOL 88 IF(VKGD(IK)) 90,80,90 SOL 89 80 WRITE(MP,2000) IK SOL 90 2000 FORMAT(' *** ERREUR,PIVOT NUL EQUATION ',I5) SOL 91 STOP SOL 92 C SOL 93 C----- RESOLUTION DU SYSTEME TRIANGULAIRE INFERIEUR SOL 94 C SOL 95 90 IF(ISOL.NE.1) GO TO 100 SOL 96 IF(NSYM.NE.1) VFG(IK)=VFG(IK)-SCAL(VKGS(JHK),VFG(IMIN1),LHK) SOL 97 IF(NSYM.EQ.1) VFG(IK)=VFG(IK)-SCAL(VKGI(JHK),VFG(IMIN1),LHK) SOL 98 100 JHK=JHK1 SOL 99 IF(ISOL.NE.1) RETURN SOL 100 C SOL 101 C----- RESOLUTION DU SYSTEME DIAGONAL : SOL 102 C SOL 103 IF(NSYM.EQ.1) GO TO 120 SOL 104 DO 110 IK=1,NEQ SOL 105 C1=VKGD(IK) SOL 106 C2=VFG(IK)/C1 SOL 107 VFG(IK)=C2 SOL 108 110 ENERG=ENERG+C1*C2*C2 SOL 109 C SOL 110 C----- RESOLUTION DU SYSTEME TRIANGULAIRE SUPERIEUR SOL 111 C SOL 112 120 IK=NEQ+1 SOL 113 JHK1=KLD(IK) SOL 114 130 IK=IK-1 SOL 115 IF(NSYM.EQ.1) VFG(IK)=VFG(IK)/VKGD(IK) SOL 116 IF(IK.EQ.1) RETURN SOL 117 C1=VFG(IK) SOL 118 JHK=KLD(IK) SOL 119 JBK=JHK1-1 SOL 120 IF(JHK.GT.JBK)GO TO 150 SOL 121 IJ=IK-JBK+JHK-1 SOL 122 DO 140 JCK=JHK,JBK SOL 123 VFG(IJ)=VFG(IJ)-VKGS(JCK)*C1 SOL 124 140 IJ=IJ+1 SOL 125 150 JHK1=JHK SOL 126 GO TO 130 SOL 127 END SOL 128 FUNCTION SCAL(X,Y,N) SCAL 1 C=======================================================================SCAL 2 C PRODUIT SCALAIRE DES VECTEURS X ET Y DE LONGUEUR N SCAL 3 C (FONCTION A ECRIRE EVENTUELLEMENT EN ASSEMBLEUR) SCAL 4 C=======================================================================SCAL 5 IMPLICIT REAL*8(A-H,O-Z) SCAL 6 DIMENSION X(1),Y(1) SCAL 7 DATA ZERO/0.0D0/ SCAL 8 C-----------------------------------------------------------------------SCAL 9 SCAL=ZERO SCAL 10 DO 10 I=1,N SCAL 11 10 SCAL=SCAL+X(I)*Y(I) SCAL 12 RETURN SCAL 13 END SCAL 14 C++++++ FIN FIGURE 5.15 C++++++ DEBUT FIGURE 6.23 SUBROUTINE BLLIND BLLD 1 C=======================================================================BLLD 2 C APPEL DU BLOC 'LIND' BLLD 3 C ASSEMBLAGE ET RESOLUTION D'UN PROBLEME LINEAIRE AVEC SEGMENTATION BLLD 4 C DE LA MATRICE KG SUR DISQUE BLLD 5 C=======================================================================BLLD 6 IMPLICIT REAL*8(A-H,O-Z) BLLD 7 REAL*4 TBL BLLD 8 COMMON/COOR/NDIM,NNT,NDLN,NDLT BLLD 9 COMMON/ELEM/NUL(4),ME BLLD 10 COMMON/ASSE/NSYM,NKG,NKE,NDLE BLLD 11 COMMON/RESO/NEQ,NRES,MRES BLLD 12 COMMON/LIND/NLBL,NBLM,MKG1,MKG2 BLLD 13 COMMON/ES/M,MR,MP,M1,M2,M3,M4,M5 BLLD 14 COMMON/ALLOC/NVA,IVA,IVAMAX,NREEL BLLD 15 COMMON/LOC/LCORG,LDLNC,LNEQ,LDIMP,LPRNG,LPREG,LLD,LLOCE,LCORE,LNE,BLLD 16 1 LPRNE,LPREE,LDLE,LKE,LFE,LKGS,LKGD,LKGI,LFG,LRES,LDLG BLLD 17 COMMON VA(1) BLLD 18 DIMENSION TBL(10),IN(3) BLLD 19 DATA TBL/4HKGS ,4HKGD ,4HKGI ,4HFG ,4HKE ,4HFE ,4HRES ,4HDLE , BLLD 20 1 4HEB ,4HPB /,DEUX/2.D0/,NBLMAX/100/ BLLD 21 C-----------------------------------------------------------------------BLLD 22 C------- FICHIERS BLLD 23 IF(M1.EQ.0) M1=MR BLLD 24 IF(M2.EQ.0) M2=ME BLLD 25 IF(M3.EQ.0) M3=MRES BLLD 26 IF(M4.EQ.0) M4=MKG1 BLLD 27 IF(M5.EQ.0) M5=MKG2 BLLD 28 C------- LECTURE DES PARAMETRES DU BLOC BLLD 29 READ(M1,1000) IN BLLD 30 1000 FORMAT(3I5) BLLD 31 IF(IN(1).NE.0) NRES=1 BLLD 32 NLBL=IN(2) BLLD 33 NBLM=IN(3) BLLD 34 WRITE(MP,2000) M,NRES BLLD 35 2000 FORMAT(//' ASSEMBLAGE-RESOLUTION LINEAIRE SUR DISQUE (M=',I2,')'/ BLLD 36 1 ' ',42('=')/15X,'INDICE DE CALCUL DU RESIDUS (NRES)=',I5) BLLD 37 IF(LKGD.EQ.1) CALL ESPACE(NEQ,1,TBL(2),LKGD) BLLD 38 IF(LFG.EQ.1) CALL ESPACE(NEQ,1,TBL(4),LFG) BLLD 39 IF(LKE.EQ.1) CALL ESPACE(NKE,1,TBL(5),LKE) BLLD 40 IF(LFE.EQ.1) CALL ESPACE(NDLE,1,TBL(6),LFE) BLLD 41 IF(LRES.EQ.1) CALL ESPACE(NDLT,1,TBL(7),LRES) BLLD 42 IF(LDLE.EQ.1) CALL ESPACE(NDLE,1,TBL(8),LDLE) BLLD 43 C------- DETERMINATION DE LA LONGUEUR DES BLOCS BLLD 44 I3=2 BLLD 45 I2=1+NSYM BLLD 46 IF(NLBL.EQ.0) GO TO 10 BLLD 47 IF(NBLM.EQ.0) NBLM=NKG/NLBL+2 BLLD 48 GO TO 30 BLLD 49 10 I1=NVA-IVA-(2*NBLMAX+2)/NREEL-1 BLLD 50 IF(I1.GE.(NKG*I2+2)) GO TO 20 BLLD 51 C------- CAS OU LA MATRICE DOIT ETRE SEGMENTEE BLLD 52 NLBL=I1/(DEUX*I2) BLLD 53 NBLM=NKG/NLBL+2 BLLD 54 GO TO 30 BLLD 55 C------- CAS OU LA MATRICE TIENT EN MEMOIRE BLLD 56 20 NLBL=NKG BLLD 57 NBLM=1 BLLD 58 I3=1 BLLD 59 30 WRITE(MP,2010) NLBL,NBLM BLLD 60 2010 FORMAT( BLLD 61 1 15X,'LONGUEUR DES BLOCS DE KG (NLBL)=',I5/ BLLD 62 2 15X,'NOMBRE MAX. DE BLOCS DE KG =',I5) BLLD 63 CALL ESPACE(NBLM+1,0,TBL(9),LEB) BLLD 64 CALL ESPACE(NBLM,0,TBL(10),LPB) BLLD 65 IF(LKGS.EQ.1) CALL ESPACE(NLBL*I3,1,TBL(1),LKGS) BLLD 66 IF(NSYM.EQ.1.AND.LKGI.EQ.1) CALL ESPACE(NLBL*I3,1,TBL(3),LKGI) BLLD 67 CALL EXLIND(VA(LLD),VA(LDIMP),VA(LLOCE),VA(LCORE),VA(LPRNE), BLLD 68 1 VA(LPREE),VA(LNE),VA(LKE),VA(LFE),VA(LKGS),VA(LKGD), BLLD 69 2 VA(LKGI),VA(LFG),VA(LCORG),VA(LDLNC),VA(LNEQ), BLLD 70 3 VA(LRES),VA(LDLE),VA(LEB),VA(LPB)) BLLD 71 RETURN BLLD 72 END BLLD 73 SUBROUTINE EXLIND(KLD,VDIMP,KLOCE,VCORE,VPRNE,VPREE,KNE,VKE,VFE, EXLD 1 1 VKGS,VKGD,VKGI,VFG,VCORG,KDLNC,KNEQ,VRES,VDLE,KEB,KPB) EXLD 2 C=======================================================================EXLD 3 C EXECUTION DU BLOC 'LIND' EXLD 4 C ASSEMBLAGE ET RESOLUTION D'UN PROBLEME LINEAIRE AVEC SEGMENTATION EXLD 5 C DE LA MATRICE KG SUR DISQUE EXLD 6 C=======================================================================EXLD 7 IMPLICIT REAL*8(A-H,O-Z) EXLD 8 COMMON/ASSE/NSYM,NKG,NKE,NDLE EXLD 9 COMMON/RESO/NEQ,NRES,MRES EXLD 10 COMMON/LIND/NLBL,NBLM,MKG1,MKG2 EXLD 11 COMMON/ES/M,MR,MP,M1,M2,M3 EXLD 12 DIMENSION KLD(1),VDIMP(1),KLOCE(1),VCORE(1),VPRNE(1),VPREE(1), EXLD 13 1 KNE(1),VKE(1),VFE(1),VKGS(1),VKGD(1),VKGI(1),VFG(1),VCORG(1), EXLD 14 2 KDLNC(1),KNEQ(1),VRES(1),VDLE(1),KEB(1),KPB(1) EXLD 15 C-----------------------------------------------------------------------EXLD 16 REWIND M3 EXLD 17 C------- CALCUL DES TABLES EB ET PB DEFINISSANT LES BLOCS D'EQUATIONS EXLD 18 CALL EQBLOC(KLD,NLBL,NBLM,NEQ,KEB,KPB) EXLD 19 WRITE(MP,2000) NBLM EXLD 20 2000 FORMAT(15X,'NOMBRE DE BLOCS DE KG (NBLM)=',I5) EXLD 21 IF(M.LT.2) GO TO 10 EXLD 22 I1=NBLM+1 EXLD 23 WRITE(MP,2010) (KEB(I),I=1,I1) EXLD 24 2010 FORMAT(/' PREMIERE EQUATION DE CHAQUE BLOC: (EB)'/(5X,20I5)) EXLD 25 WRITE(MP,2020) (KPB(I),I=1,NBLM) EXLD 26 2020 FORMAT(/' PREMIER BLOC CONNECTE A CHAQUE BLOC: (PB)'/(5X,20I5)) EXLD 27 C------ SAUVER FG NON MODIFIE PAR LES C.L. IMPOSEES EXLD 28 10 WRITE (M3) (VFG(I),I=1,NEQ) EXLD 29 IF(M.GE.2) WRITE(MP,2030) (VFG(I),I=1,NEQ) EXLD 30 2030 FORMAT(/' VECTEUR SOLLICITATIONS GLOBAL NON MODIFIE PAR LES C.L. (EXLD 31 1FG)'/(1X,10E12.5)) EXLD 32 C------- ASSEMBLER KG,MODIFIER FG POUR LES C.L. ET SAUVER FG MODIFIE EXLD 33 CALL ASKGD(KLD,VDIMP,KLOCE,VCORE,VPRNE,VPREE,KNE,VKE,VFE,VKGS, EXLD 34 1 VKGD,VKGI,VFG,VDLE,VRES,KEB) EXLD 35 WRITE(M3) (VFG(I),I=1,NEQ) EXLD 36 C------- IMPRESSION DE FG EXLD 37 IF(M.GE.2) WRITE(MP,2040) (VFG(I),I=1,NEQ) EXLD 38 2040 FORMAT(/' VECTEUR SOLLICITATIONS GLOBAL MODIFIE PAR LES C.L. (FG)'EXLD 39 1 /(1X,10E12.5)) EXLD 40 C EXLD 41 C------- RESOLUTION EXLD 42 C EXLD 43 20 CALL SOLD(VKGS,VKGD,VKGI,VFG,KLD,NEQ,MP,1,1,NSYM,ENERG,KEB,KPB) EXLD 44 IF(NSYM.NE.1) WRITE(MP,2050) ENERG EXLD 45 2050 FORMAT(15X,'ENERGIE (ENERG)=',1E12.5) EXLD 46 C------- PIVOTS DE KG ET DETERMINANT EXLD 47 30 CALL PRPVTS(VKGD) EXLD 48 C------- IMPRESSION DE LA SOLUTION EXLD 49 WRITE(MP,2060) EXLD 50 2060 FORMAT(//' SOLUTION'//) EXLD 51 CALL PRSOL(KDLNC,VCORG,VDIMP,KNEQ,VFG) EXLD 52 C EXLD 53 C------- CALCUL ET IMPRESSION DES GRADIENTS EXLD 54 C EXLD 55 CALL ASGRAD(KLD,VDIMP,KLOCE,VCORE,VPRNE,VPREE,KNE,VKE,VFE,VKGS, EXLD 56 1 VKGD,VKGI,VFG,VDLE,VRES) EXLD 57 C EXLD 58 C------- CALCUL ET IMPRESSION DES RESIDUS D'EQUILIBRE ET REACTIONS EXLD 59 C EXLD 60 C------- LIRE LE VECTEUR FG ET LE CHANGER DE SIGNE EXLD 61 REWIND M3 EXLD 62 READ(M3) (VRES(I),I=1,NEQ) EXLD 63 DO 40 I=1,NEQ EXLD 64 40 VRES(I)=-VRES(I) EXLD 65 C------- ASSEMBLER LES RESIDUS ET LES REACTIONS EXLD 66 CALL ASRESD(1,1,KLD,VDIMP,KLOCE,VCORE,VPRNE,VPREE,KNE,VKE,VFE, EXLD 67 1 VKGS,VKGD,VKGI,VFG,VDLE,VRES,VRES(NEQ+1)) EXLD 68 C------- IMPRESSION EXLD 69 WRITE(MP,2070) EXLD 70 2070 FORMAT(//' RESIDUS D EQUILIBRE ET REACTIONS'//) EXLD 71 CALL PRSOL(KDLNC,VCORG,VRES(NEQ+1),KNEQ,VRES) EXLD 72 RETURN EXLD 73 END EXLD 74 SUBROUTINE EQBLOC(KLD,NLBL,NBLMAX,NEQ,KEB,KPB) EQBL 1 C=======================================================================EQBL 2 C CALCUL DES TABLES KEB ET KPB DEFINISSANT LES BLOCS D'EQUATIONS EQBL 3 C ENTREES EQBL 4 C KLD TABLE DES POINTEURS DES HAUTS DE COLONNE DE KG EQBL 5 C NLBL LONGUEUR DES BLOCS EQBL 6 C NBLMAX NOMBRE MAX. DE BLOCS ADMISSIBLE EQBL 7 C NEQ NOMBRE D EQUATIONS EQBL 8 C SORTIES EQBL 9 C KEB TABLE DES NUMEROS DES PREMIERES EQUATIONS DE CHAQUE EQBL 10 C BLOC (DIMENSION NEQ+1) EQBL 11 C KPB TABLE DES NUMEROS DES PREMIERS BLOCS CONNECTES A EQBL 12 C CHAQUE BLOC (DIMENSION NEQ) EQBL 13 C NBLMAX NOMBRE DE BLOCS EQBL 14 C=======================================================================EQBL 15 COMMON/ES/M,MR,MP EQBL 16 DIMENSION KLD(1),KEB(1),KPB(1) EQBL 17 C-----------------------------------------------------------------------EQBL 18 C------- PREMIER BLOC EQBL 19 ILBL=0 EQBL 20 NBL=1 EQBL 21 KEB(1)=1 EQBL 22 KPB(1)=1 EQBL 23 IMIN=1 EQBL 24 C------- POUR CHAQUE EQUATION EQBL 25 DO 70 IK=1,NEQ EQBL 26 C------- POINTEURS DE LA COLONNE IK EQBL 27 JHK=KLD(IK) EQBL 28 JHK1=KLD(IK+1) EQBL 29 LBK1=JHK1-JHK EQBL 30 IF(LBK1.LE.NLBL) GO TO 10 EQBL 31 WRITE(MP,2000) IK,LBK1,NLBL EQBL 32 2000 FORMAT(' *** ERREUR,COLONNE',I5,' PLUS GRANDE(',I5,')QUE LE BLOC('EQBL 33 1 ,I5,')') EQBL 34 STOP EQBL 35 C------- TEST POUR UN NOUVEAU BLOC EQBL 36 10 ILBL=ILBL+LBK1 EQBL 37 IF(ILBL.LE.NLBL) GO TO 60 EQBL 38 NBL=NBL+1 EQBL 39 IF(NBL.LE.NBLMAX) GO TO 20 EQBL 40 WRITE(MP,2010) IK EQBL 41 2010 FORMAT(' *** ERREUR,NOMBRE DE BLOCS TROP ELEVE,EQUATION',I5) EQBL 42 STOP EQBL 43 20 KEB(NBL)=IK EQBL 44 ILBL=LBK1 EQBL 45 C------- RECHERCHE DU PREMIER BLOC CONNECTE AU BLOC TERMINE EQBL 46 IB=NBL EQBL 47 40 IF(IMIN.GE.KEB(IB)) GO TO 50 EQBL 48 IB=IB-1 EQBL 49 GO TO 40 EQBL 50 50 KPB(NBL-1)=IB EQBL 51 IMIN=IK EQBL 52 C------- RECHERCHE DU NUMERO DE LIGNE MINIMUM DES HAUTS DE COLONNE EQBL 53 60 I=IK-LBK1+1 EQBL 54 IF(I.LT.IMIN)IMIN=I EQBL 55 70 CONTINUE EQBL 56 C------- PREMIER BLOC CONNECTE AU DERNIER BLOC EQBL 57 IB=NBL EQBL 58 80 IF(IMIN.GE.KEB(IB)) GO TO 90 EQBL 59 IB=IB-1 EQBL 60 GO TO 80 EQBL 61 90 KPB(NBL)=IB EQBL 62 KEB(NBL+1)=NEQ+1 EQBL 63 NBLMAX=NBL EQBL 64 RETURN EQBL 65 END EQBL 66 SUBROUTINE ASKGD(KLD,VDIMP,KLOCE,VCORE,VPRNE,VPREE,KNE,VKE,VFE, ASKD 1 1 VKGS,VKGD,VKGI,VFG,VDLE,VRES,KEB) ASKD 2 C=======================================================================ASKD 3 C ASSEMBLAGE DE LA MATRICE GLOBALE KG (FONCTION ELEMENTAIRE ASKD 4 C DE TYPE 3) AVEC PRISE EN COMPTE DES D.L. IMPOSES NON NULS ASKD 5 C VERSION AVEC MATRICE KG SEGMENTEE SUR LE FICHIER M4 ASKD 6 C=======================================================================ASKD 7 IMPLICIT REAL*8(A-H,O-Z) ASKD 8 COMMON/COND/NCLT,NCLZ,NCLNZ ASKD 9 COMMON/ELEM/NELT,NNEL,NTPE,NGRE,ME,NIDENT ASKD 10 COMMON/ASSE/NSYM ASKD 11 COMMON/RESO/NEQ ASKD 12 COMMON/RGDT/IEL,ITPE,ITPE1,IGRE,IDLE,ICE,IPRNE,IPREE,INEL,IDEG,IPGASKD 13 1 ,ICOD ASKD 14 COMMON/LIND/NLBL,NBLM,MKG1,MKG2 ASKD 15 COMMON/ES/M,MR,MP,M1,M2,M3,M4,M5 ASKD 16 DIMENSION KLD(1),VDIMP(1),KLOCE(1),VCORE(1),VPRNE(1),VPREE(1), ASKD 17 1 KNE(1),VKE(1),VFE(1),VKGS(1),VKGD(1),VKGI(1),VFG(1),VDLE(1), ASKD 18 1 VRES(1),KEB(1) ASKD 19 DATA ZERO/0.D0/ ASKD 20 C-----------------------------------------------------------------------ASKD 21 C------- POSITIONNER AU DEBUT LE FICHIER M4 ASKD 22 REWIND M4 ASKD 23 C------- BOUCLE SUR LES BLOCS ASKD 24 DO 80 IB=1,NBLM ASKD 25 C------- INITIALISER LE BLOC ASKD 26 DO 10 I=1,NLBL ASKD 27 IF(NSYM.EQ.1) VKGI(I)=ZERO ASKD 28 10 VKGS(I)=ZERO ASKD 29 IE1=KEB(IB) ASKD 30 IE2=KEB(IB+1)-1 ASKD 31 C------- POSITIONNER AU DEBUT LE FICHIER DES ELEMENTS (M2) ASKD 32 REWIND M2 ASKD 33 C------- BOUCLE SUR LES ELEMENTS ASKD 34 DO 70 IE=1,NELT ASKD 35 C------- LIRE UN ELEMENT ASKD 36 CALL RDELEM(M2,KLOCE,VCORE,VPRNE,VPREE,KNE) ASKD 37 C------- L'ELEMENT INTERVIENT-IL DANS LE BLOC ASKD 38 DO 20 ID=1,IDLE ASKD 39 J=KLOCE(ID) ASKD 40 IF(J.LT.IE1.OR.J.GT.IE2) GO TO 20 ASKD 41 GO TO 40 ASKD 42 20 CONTINUE ASKD 43 30 IF(IB.NE.1.OR.(NCLNZ.EQ.0.AND.IB.EQ.1)) GO TO 70 ASKD 44 C------- CALCUL DES FONCTIONS D'INTERPOLATION SI NECESSAIRE ASKD 45 40 IF(ITPE.EQ.ITPE1) GO TO 50 ASKD 46 ICOD=2 ASKD 47 CALL ELEMLB(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ASKD 48 C------- CALCUL DE LA MATRICE ELEMENTAIRE ASKD 49 50 ICOD=3 ASKD 50 CALL ELEMLB(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ASKD 51 C------- IMPRESSION DE LA MATRICE ELEMENTAIRE ASKD 52 IF(M.LT.2) GO TO 60 ASKD 53 IF(NSYM.EQ.0) IKE=IDLE*(IDLE+1)/2 ASKD 54 IF(NSYM.EQ.1) IKE=IDLE*IDLE ASKD 55 WRITE(MP,2000) IEL,(VKE(I),I=1,IKE) ASKD 56 2000 FORMAT(/' MATRICE (KE) , ELEMENT:',I5/(10X,10E12.5)) ASKD 57 C------- MODIFICATION DE FG DUE AUX D.L. IMPOSES NON NULS ASKD 58 60 IF(NCLNZ.NE.0.AND.IB.EQ.1) CALL MODFG(IDLE,NSYM,KLOCE,VDIMP,VKE, ASKD 59 1 VFG) ASKD 60 C------- ASSEMBLAGE ASKD 61 CALL ASSELD(1,0,IDLE,NSYM,IE1,IE2,KLOCE,KLD,VKE,VFE,VKGS,VKGD, ASKD 62 1 VKGI,VFG) ASKD 63 ITPE1=ITPE ASKD 64 70 CONTINUE ASKD 65 C------- FIN D'UN BLOC ASKD 66 WRITE(M4) (VKGS(I),I=1,NLBL) ASKD 67 IF(NSYM.EQ.1) WRITE(M4) (VKGI(I),I=1,NLBL) ASKD 68 IF(M.LT.2) GO TO 80 ASKD 69 WRITE(MP,2010) IB,(VKGS(I),I=1,NLBL) ASKD 70 2010 FORMAT(' BLOC DU TRIANGLE SUPERIEUR DE (KG) NO:',I5/(1X,10E12.5)) ASKD 71 IF(NSYM.EQ.1) WRITE(MP,2020) IB,(VKGI(I),I=1,NLBL) ASKD 72 2020 FORMAT(' BLOC DU TRIANGLE INFERIEUR DE (KG) NO:',I5/(1X,10E12.5)) ASKD 73 80 CONTINUE ASKD 74 IF(M.GE.2) WRITE(MP,2030) (VKGD(I),I=1,NEQ) ASKD 75 2030 FORMAT(' DIAGONALE DE (KG)'/(1X,10E12.5)) ASKD 76 RETURN ASKD 77 END ASKD 78 SUBROUTINE ASSELD(IKG,IFG,IDLE,NSYM,IE1,IE2,KLOCE,KLD,VKE,VFE, ASSD 1 1 VKGS,VKGD,VKGI,VFG) ASSD 2 C=======================================================================ASSD 3 C ASSEMBLAGE D'UNE MATRICE ELEMENTAIRE (SYMETRIQUE OU NON) ET/OU ASSD 4 C D'UN VECTEUR ELEMENTAIRE. LA MATRICE EST SEGMENTEE SUR DISQUE ASSD 5 C ENTREES ASSD 6 C IKG SI IKG.EQ.1 ASSEMBLAGE DE LA MATRICE ELEMENTAIRE KE ASSD 7 C IFG SI IFG.EQ.1 ASSEMBLAGE DU VECTEUR ELEMENTAIRE FE ASSD 8 C IDLE NOMBRE DE D.L. DE L'ELEMENT ASSD 9 C NSYM 0=PROBLEME SYMETRIQUE, 1=PROBLEME NON SYMETRIQUE ASSD 10 C IE1,IE2 PREMIERE ET DERNIERE COLONNE DE KG A ASSEMBLER ASSD 11 C KLOCE VECTEUR DE LOCALISATION DE L'ELEMENT ASSD 12 C KLD HAUTEURS CUMULEES DE COLONNES DE KG ASSD 13 C VKE MATRICE ELEMENTAIRE KE(PLEINE OU TRIANGLE SUPERIEUR ASSD 14 C PAR COLONNES DESCENDANTES) ASSD 15 C VFE VECTEUR ELEMENTAIRE FE ASSD 16 C SORTIES ASSD 17 C VKGS,VKGD,VKGI MATRICE GLOBALE (LIGNE DE CIEL) ASSD 18 C (SYMETRIQUE OU NON) ASSD 19 C VFG VECTEUR SOLLICITATIONS GLOBAL ASSD 20 C=======================================================================ASSD 21 IMPLICIT REAL*8(A-H,O-Z) ASSD 22 DIMENSION KLOCE(1),KLD(1),VKE(1),VFE(1),VKGS(1),VKGD(1), ASSD 23 1 VKGI(1),VFG(1) ASSD 24 C-----------------------------------------------------------------------ASSD 25 C ASSD 26 C------- ASSEMBLAGE DE LA MATRICE ELEMENTAIRE ASSD 27 C ASSD 28 IF(IKG.NE.1) GO TO 100 ASSD 29 I0BLOC=KLD(IE1)-1 ASSD 30 IEQ0=IDLE ASSD 31 IEQ1=1 ASSD 32 C------- POUR CHAQUE COLONNE DE KE ASSD 33 DO 90 JD=1,IDLE ASSD 34 IF(NSYM.NE.1) IEQ0=JD ASSD 35 JL=KLOCE(JD) ASSD 36 IF(JL) 90,90,10 ASSD 37 10 I0=KLD(JL+1)-I0BLOC ASSD 38 IEQ=IEQ1 ASSD 39 IQ=1 ASSD 40 IF(JL.LT.IE1.OR.JL.GT.IE2) GO TO 90 ASSD 41 C------- POUR CHAQUE LIGNE DE KE ASSD 42 DO 80 ID=1,IDLE ASSD 43 IL=KLOCE(ID) ASSD 44 IF(NSYM.EQ.1) GO TO 30 ASSD 45 IF(ID-JD) 30,20,20 ASSD 46 20 IQ=ID ASSD 47 30 IF(IL) 80,80,40 ASSD 48 40 IJ=JL-IL ASSD 49 IF(IJ) 80,50,60 ASSD 50 C------- TERMES DIAGONAUX DE KG ASSD 51 50 VKGD(IL)=VKGD(IL)+VKE(IEQ) ASSD 52 GO TO 80 ASSD 53 C------- TERMES DU TRIANGLE SUPERIEUR DE KG ASSD 54 60 I=I0-IJ ASSD 55 VKGS(I)=VKGS(I)+VKE(IEQ) ASSD 56 IF(NSYM.NE.1) GO TO 80 ASSD 57 C------- TERMES DU TRIANGLE INFERIEUR DE KG ASSD 58 IEQI=(ID-1)*IDLE+JD ASSD 59 VKGI(I)=VKGI(I)+VKE(IEQI) ASSD 60 80 IEQ=IEQ+IQ ASSD 61 90 IEQ1=IEQ1+IEQ0 ASSD 62 C ASSD 63 C------- ASSEMBLAGE DU VECTEUR ELEMENTAIRE ASSD 64 C ASSD 65 100 IF(IFG.NE.1) GO TO 130 ASSD 66 DO 120 ID=1,IDLE ASSD 67 IL=KLOCE(ID) ASSD 68 IF(IL) 120,120,110 ASSD 69 110 VFG(IL)=VFG(IL)+VFE(ID) ASSD 70 120 CONTINUE ASSD 71 130 RETURN ASSD 72 END ASSD 73 C++++++ FIN FIGURE 6.23 C++++++ DEBUT FIGURE 5.16 SUBROUTINE SOLD(VKGS,VKGD,VKGI,VFG,KLD,NEQ,MP,IFAC,ISOL,NSYM,ENERGSOLD 1 1 ,KEB,KPB) SOLD 2 C=======================================================================SOLD 3 C RESOLUTION D'UN SYSTEME LINEAIRE SYMETRIQUE OU NON. LA MATRICE SOLD 4 C EST STOCKEE PAR LIGNE DE CIEL SUR LE FICHIER M4. APRES TRIANGULA- SOLD 5 C RISATION ELLE EST PLACEE SUR LE FICHIER M5 SOLD 6 C ENTREES SOLD 7 C VKGS,VKGD,VKGI MATRICE DU SYSTEME : PARTIES SUPERIEURE, SOLD 8 C DIAGONALE, INFERIEURE SOLD 9 C VFG SECOND MEMBRE SOLD 10 C KLD POINTEURS VERS LES HAUTS DE COLONNE SOLD 11 C NEQ NOMBRE D'EQUATIONS SOLD 12 C MP UNITE LOGIQUE D'IMPRESSION SOLD 13 C IFAC SI IFAC.EQ.1 TRIANGULARISATION DE SOLD 14 C LA MATRICE SOLD 15 C ISOL SI ISOL.EQ.1 CALCUL DE LA SOLUTION A SOLD 16 C PARTIR DE LA MATRICE TRIANGULARISEE SOLD 17 C NSYM INDICE DE PROBLEME NON SYMETRIQUE SOLD 18 C KEB NUMERO DE LA PREMIERE EQUATION DE CHAQUE SOLD 19 C BLOC SOLD 20 C KPB NUMERO DU PREMIER BLOC CONNECTE A CHAQUE SOLD 21 C BLOC SOLD 22 C SORTIES SOLD 23 C VKGS,VKGD,VKGI MATRICE TRIANGULARISEE (SI IFAC.EQ.1) SOLD 24 C VFG SOLUTION (SI ISOL.EQ.1) SOLD 25 C ENERG ENERGIE DU SYSTEME (SI NSYM.EQ.0) SOLD 26 C=======================================================================SOLD 27 IMPLICIT REAL*8 (A-H,O-Z) SOLD 28 COMMON/LIND/NLBL,NBLM SOLD 29 COMMON/ES/M,MR,MP1,M1,M2,M3,M4,M5 SOLD 30 DIMENSION VKGS(1),VKGD(1),VKGI(1),VFG(1),KLD(1),KEB(1),KPB(1) SOLD 31 DATA ZERO/0.0D0/ SOLD 32 C-----------------------------------------------------------------------SOLD 33 REWIND M4 SOLD 34 REWIND M5 SOLD 35 IK=1 SOLD 36 IF(VKGD(1).NE.ZERO) GO TO 5 SOLD 37 WRITE(MP,2000) IK SOLD 38 STOP SOLD 39 5 ENERG=ZERO SOLD 40 C SOLD 41 C------- POUR CHAQUE BLOC A TRIANGULARISER SOLD 42 C SOLD 43 J1MIN=NLBL+1 SOLD 44 J1MAX=NLBL+NLBL SOLD 45 DO 105 IB=1,NBLM SOLD 46 C------- LIRE UN BLOC A TRIANGULARISER SOLD 47 READ(M4) (VKGS(I),I=1,NLBL) SOLD 48 IF(NSYM.EQ.1) READ(M4) (VKGI(I),I=1,NLBL) SOLD 49 C------- PARAMETRES DU BLOC IB SOLD 50 IK0=KEB(IB) SOLD 51 IK1=KEB(IB+1)-1 SOLD 52 IB0=KPB(IB) SOLD 53 J0=KLD(IK0)-1 SOLD 54 IF(IB0.EQ.IB) GO TO 11 SOLD 55 C------- BACKSPACE SUR LES BLOCS CONNECTES SOLD 56 I1=IB-IB0 SOLD 57 DO 10 I=1,I1 SOLD 58 BACKSPACE M5 SOLD 59 IF(NSYM.EQ.1) BACKSPACE M5 SOLD 60 10 CONTINUE SOLD 61 C------- POUR CHAQUE BLOC CONNECTE(INCLUANT LE BLOC IB LUI-MEME) SOLD 62 11 DO 103 IBC=IB0,IB SOLD 63 IF(IBC.EQ.IB) GO TO 12 SOLD 64 READ(M5) (VKGS(I),I=J1MIN,J1MAX) SOLD 65 IF(NSYM.EQ.1) READ(M5) (VKGI(I),I=J1MIN,J1MAX) SOLD 66 C------- PARAMETRES DU BLOC CONNECTE SOLD 67 12 II0=KEB(IBC) SOLD 68 II1=KEB(IBC+1)-1 SOLD 69 JC0=KLD(II0)-1 SOLD 70 IF(IBC.NE.IB) JC0=JC0-NLBL SOLD 71 C SOLD 72 C------- POUR CHAQUE COLONNE DU BLOC IB A MODIFIER SOLD 73 C SOLD 74 DO 100 IK=IK0,IK1 SOLD 75 JHK=KLD(IK)-J0 SOLD 76 C----- POINTEUR DU HAUT DE LA COLONNE SUIVANTE IK+1 SOLD 77 JHK1=KLD(IK+1)-J0 SOLD 78 C----- HAUTEUR DE LA COLONNE IK (HORS TERMES SUPERIEUR ET DIAGONAL) SOLD 79 LHK=JHK1-JHK SOLD 80 LHK1=LHK-1 SOLD 81 C----- LIGNE DU PREMIER TERME A MODIFIER DANS LA COLONNE IK SOLD 82 IMIN=IK-LHK1 SOLD 83 IMIN1=IMIN-1 SOLD 84 C------- LIGNE DU DERNIER TERME A MODIFIER DANS LA COLONNE IK SOLD 85 IMAX=IK-1 SOLD 86 IF(LHK1.LT.0) GO TO 100 SOLD 87 IF(IFAC.NE.1) GO TO 90 SOLD 88 IF(NSYM.EQ.0) GO TO 14 SOLD 89 IB1=IB SOLD 90 IF(IMIN1.LT.IK0) IB1=IB0 SOLD 91 IF(IBC.EQ.IB1) VKGI(JHK)=VKGI(JHK)/VKGD(IMIN1) SOLD 92 14 IF(IBC.EQ.IB.AND.IK.EQ.IK0) GO TO 40 SOLD 93 IF(LHK1.EQ.0) GO TO 40 SOLD 94 C------- TROUVER LA PREMIERE ET LA DERNIERE LIGNE DE LA COLONNE IK SOLD 95 C INFLUENCEE PAR LE BLOC CONNECTE IBC SOLD 96 IMINC=MAX0(IMIN,II0) SOLD 97 IMAXC=MIN0(IMAX,II1) SOLD 98 IF(IMINC.GT.IMAXC) GO TO 40 SOLD 99 C SOLD 100 C----- MODIFIER LES TERMES NON DIAGONAUX DE LA COLONNE IK SOLD 101 C SOLD 102 JCK=JHK+IMINC-IMIN1 SOLD 103 JHJ=KLD(IMINC)-JC0 SOLD 104 C------- POUR CHAQUE TERME A MODIFIER PLACE EN JCK SOLD 105 DO 30 IJ=IMINC,IMAXC SOLD 106 JHJ1=KLD(IJ+1)-JC0 SOLD 107 C----- NOMBRE DE TERMES MODIFICATIFS DU TERME PLACE EN JCK SOLD 108 IC=MIN0(JCK-JHK,JHJ1-JHJ) SOLD 109 IF(IC.LE.0.AND.NSYM.EQ.0) GO TO 20 SOLD 110 C1=ZERO SOLD 111 IF(IC.LE.0) GO TO 17 SOLD 112 J1=JHJ1-IC SOLD 113 J2=JCK-IC SOLD 114 IF(NSYM.EQ.1) GO TO 15 SOLD 115 VKGS(JCK)=VKGS(JCK)-SCAL(VKGS(J1),VKGS(J2),IC) SOLD 116 GO TO 20 SOLD 117 15 VKGS(JCK)=VKGS(JCK)-SCAL(VKGI(J1),VKGS(J2),IC) SOLD 118 C1=SCAL(VKGS(J1),VKGI(J2),IC) SOLD 119 17 VKGI(JCK)=(VKGI(JCK)-C1)/VKGD(IJ) SOLD 120 20 JCK=JCK+1 SOLD 121 30 JHJ=JHJ1 SOLD 122 C SOLD 123 C----- MODIFIER LE TERME DIAGONAL SOLD 124 C SOLD 125 40 IF(IBC.NE.IB) GO TO 90 SOLD 126 JCK=JHK SOLD 127 CDIAG=ZERO SOLD 128 DO 70 IJ=IMIN1,IMAX SOLD 129 C1=VKGS(JCK) SOLD 130 IF(NSYM.EQ.1) GO TO 50 SOLD 131 C2=C1/VKGD(IJ) SOLD 132 VKGS(JCK)=C2 SOLD 133 GO TO 60 SOLD 134 50 C2=VKGI(JCK) SOLD 135 60 CDIAG=CDIAG+C1*C2 SOLD 136 70 JCK=JCK+1 SOLD 137 VKGD(IK)=VKGD(IK)-CDIAG SOLD 138 IF(VKGD(IK)) 90,80,90 SOLD 139 80 WRITE(MP,2000) IK SOLD 140 2000 FORMAT(' *** ERREUR,PIVOT NUL EQUATION ',I5) SOLD 141 STOP SOLD 142 C SOLD 143 C----- RESOLUTION DU SYSTEME TRIANGULAIRE INFERIEUR SOLD 144 C SOLD 145 90 IF(ISOL.NE.1) GO TO 100 SOLD 146 IF(IBC.NE.IB) GO TO 100 SOLD 147 IF(NSYM.NE.1) VFG(IK)=VFG(IK)-SCAL(VKGS(JHK),VFG(IMIN1),LHK) SOLD 148 IF(NSYM.EQ.1) VFG(IK)=VFG(IK)-SCAL(VKGI(JHK),VFG(IMIN1),LHK) SOLD 149 100 CONTINUE SOLD 150 C------- PROCHAIN BLOC CONNECTE SOLD 151 103 CONTINUE SOLD 152 C------- FIN DE L'ELIMINATION DU BLOC SOLD 153 IF(IB.EQ.NBLM) GO TO 105 SOLD 154 WRITE(M5) (VKGS(I),I=1,NLBL) SOLD 155 IF(NSYM.EQ.1) WRITE(M5) (VKGI(I),I=1,NLBL) SOLD 156 105 CONTINUE SOLD 157 IF(ISOL.NE.1) RETURN SOLD 158 C SOLD 159 C----- RESOLUTION DU SYSTEME DIAGONAL SOLD 160 C SOLD 161 IF(NSYM.EQ.1) GO TO 120 SOLD 162 DO 110 IK=1,NEQ SOLD 163 C1=VKGD(IK) SOLD 164 C2=VFG(IK)/C1 SOLD 165 VFG(IK)=C2 SOLD 166 110 ENERG=ENERG+C1*C2*C2 SOLD 167 C SOLD 168 C----- RESOLUTION DU SYSTEME TRIANGULAIRE SUPERIEUR SOLD 169 C SOLD 170 120 IB=NBLM SOLD 171 IK0=KEB(IB)-1 SOLD 172 J0=KLD(IK0+1)-1 SOLD 173 IK=NEQ+1 SOLD 174 JHK1=KLD(IK)-J0 SOLD 175 C------- POUR CHAQUE EQUATION DE NEQ A 1 SOLD 176 130 IK=IK-1 SOLD 177 C------- LIRE UN BLOC SI NECESSAIRE SOLD 178 IF(IK.NE.IK0) GO TO 135 SOLD 179 BACKSPACE M5 SOLD 180 IF(NSYM.EQ.1) BACKSPACE M5 SOLD 181 READ(M5) (VKGS(I),I=1,NLBL) SOLD 182 IF(NSYM.EQ.1) READ(M5) (VKGI(I),I=1,NLBL) SOLD 183 BACKSPACE M5 SOLD 184 IF(NSYM.EQ.1) BACKSPACE M5 SOLD 185 IB=IB-1 SOLD 186 IK0=KEB(IB)-1 SOLD 187 J0=KLD(IK0+1)-1 SOLD 188 JHK1=KLD(IK+1)-J0 SOLD 189 C------- MODIFIER LE VECTEUR DES INCONNUES SOLD 190 135 IF(NSYM.EQ.1) VFG(IK)=VFG(IK)/VKGD(IK) SOLD 191 IF(IK.EQ.1) RETURN SOLD 192 C1=VFG(IK) SOLD 193 JHK=KLD(IK)-J0 SOLD 194 JBK=JHK1-1 SOLD 195 IF(JHK.GT.JBK)GO TO 150 SOLD 196 IJ=IK-JBK+JHK-1 SOLD 197 DO 140 JCK=JHK,JBK SOLD 198 VFG(IJ)=VFG(IJ)-VKGS(JCK)*C1 SOLD 199 140 IJ=IJ+1 SOLD 200 150 JHK1=JHK SOLD 201 GO TO 130 SOLD 202 END SOLD 203 C++++++ FIN FIGURE 5.16 C++++++ DEBUT FIGURE 6.24 SUBROUTINE BLNLIN BLNL 1 C=======================================================================BLNL 2 C APPEL DU BLOC 'NLIN' BLNL 3 C RESOLUTION D'UN PROBLEME STATIONNAIRE NON LINEAIRE BLNL 4 C=======================================================================BLNL 5 IMPLICIT REAL*8(A-H,O-Z) BLNL 6 REAL*4 TBL BLNL 7 COMMON/ELEM/NUL(4),ME BLNL 8 COMMON/ASSE/NSYM,NKG,NKE,NDLE BLNL 9 COMMON/RESO/NEQ BLNL 10 COMMON/NLIN/EPSDL,XNORM,OMEGA,XPAS,DPAS,DPAS0,NPAS,IPAS,NITER, BLNL 11 1 ITER,IMETH BLNL 12 COMMON/ES/M,MR,MP,M1,M2,M3,M4 BLNL 13 COMMON/LOC/LCORG,LDLNC,LNEQ,LDIMP,LPRNG,LPREG,LLD,LLOCE,LCORE,LNE,BLNL 14 1 LPRNE,LPREE,LDLE,LKE,LFE,LKGS,LKGD,LKGI,LFG,LRES,LDLG,LME BLNL 15 COMMON VA(1) BLNL 16 DIMENSION TBL(10),IN(2),XIN(3) BLNL 17 DATA TBL/4HKGS ,4HKGD ,4HKGI ,4HFG ,4HKE , BLNL 18 1 4HFE ,4HRES ,4HDLE ,4HDLG ,4HME / BLNL 19 C-----------------------------------------------------------------------BLNL 20 IF(M1.EQ.0) M1=MR BLNL 21 IF(M2.EQ.0) M2=ME BLNL 22 WRITE(MP,2000) M BLNL 23 2000 FORMAT(//' RESOLUTION NON LINEAIRE (M=',I2,')'/1X,23('=')) BLNL 24 C------- ALLOCATION D'ESPACE BLNL 25 IF(LKGS.EQ.1) CALL ESPACE(NKG,1,TBL(1),LKGS) BLNL 26 IF(LKGD.EQ.1) CALL ESPACE(NEQ,1,TBL(2),LKGD) BLNL 27 IF(NSYM.EQ.1.AND.LKGI.EQ.1) CALL ESPACE(NKG,1,TBL(3),LKGI) BLNL 28 IF(LFG.EQ.1) CALL ESPACE (NEQ,1,TBL(4),LFG) BLNL 29 IF(LKE.EQ.1) CALL ESPACE(NKE,1,TBL(5),LKE) BLNL 30 IF(LFE.EQ.1) CALL ESPACE(NDLE,1,TBL(6),LFE) BLNL 31 IF(LRES.EQ.1) CALL ESPACE(NEQ,1,TBL(7),LRES) BLNL 32 IF(LDLE.EQ.1) CALL ESPACE(NDLE,1,TBL(8),LDLE) BLNL 33 IF(LDLG.EQ.1) CALL ESPACE(NEQ,1,TBL(9),LDLG) BLNL 34 IF(LME.EQ.1) CALL ESPACE(NKE,1,TBL(10),LME) BLNL 35 C------- EXECUTION DU BLOC BLNL 36 CALL EXNLIN(VA(LCORG),VA(LDLNC),VA(LDIMP),VA(LNEQ),VA(LLD), BLNL 37 1 VA(LLOCE),VA(LCORE),VA(LPRNE),VA(LPREE),VA(LNE),VA(LKE),VA(LME),BLNL 38 2 VA(LFE),VA(LDLE),VA(LKGS),VA(LKGD),VA(LKGI),VA(LFG),VA(LRES), BLNL 39 3 VA(LDLG)) BLNL 40 RETURN BLNL 41 END BLNL 42 SUBROUTINE EXNLIN(VCORG,KDLNC,VDIMP,KNEQ,KLD,KLOCE,VCORE,VPRNE, EXNL 1 1 VPREE,KNE,VKE,VME,VFE,VDLE,VKGS,VKGD,VKGI,VFG,VRES,VDLG) EXNL 2 C=======================================================================EXNL 3 C EXECUTION DU BLOC 'NLIN' EXNL 4 C RESOLUTION D'UN PROBLEME STATIONNAIRE NON LINEAIRE EXNL 5 C=======================================================================EXNL 6 IMPLICIT REAL*8(A-H,O-Z) EXNL 7 COMMON/RESO/NEQ EXNL 8 COMMON/COND/NCLT,NCLZ,NCLNZ EXNL 9 COMMON/ASSE/NSYM EXNL 10 COMMON/NLIN/EPSDL,XNORM,OMEGA,XPAS,DPAS,DPAS0,NPAS,IPAS,NITER, EXNL 11 1 ITER,IMETH EXNL 12 COMMON/ES/M,MR,MP,M1,M2,M3,M4 EXNL 13 DIMENSION VCORG(1),KDLNC(1),VDIMP(1),KNEQ(1),KLD(1),KLOCE(1), EXNL 14 1 VCORE(1),VPRNE(1),VPREE(1),KNE(1),VKE(1),VME(1),VFE(1),VDLE(1), EXNL 15 2 VKGS(1),VKGD(1),VKGI(1),VFG(1),VRES(1),VDLG(1) EXNL 16 DATA ZERO/0.D0/ EXNL 17 C-----------------------------------------------------------------------EXNL 18 DPAS0=ZERO EXNL 19 XPAS=ZERO EXNL 20 IPAS=0 EXNL 21 C------- LECTURE DES DEGRES DE LIBERTE INITIAUX SUR LE FICHIER M3 EXNL 22 IF(M3.EQ.0) GO TO 10 EXNL 23 REWIND M3 EXNL 24 READ(M3) (VDLG(I),I=1,NEQ) EXNL 25 C------- LIRE UNE CARTE DEFINISSANT UN ENSEMBLE DE PAS IDENTIQUES EXNL 26 10 READ(M1,1000) DPAS,I1,I2,I3,X1,X2 EXNL 27 1000 FORMAT(F10.0,3I5,2F10.0) EXNL 28 IF(DPAS.EQ.ZERO) GO TO 140 EXNL 29 IF(I1.GT.0) NPAS=I1 EXNL 30 IF(I2.GT.0) NITER=I2 EXNL 31 IF(I3.GT.0) IMETH=I3 EXNL 32 IF(X1.GT.ZERO) EPSDL=X1 EXNL 33 IF(X2.GT.ZERO) OMEGA=X2 EXNL 34 C EXNL 35 C------- BOUCLE SUR LES PAS EXNL 36 C EXNL 37 DO 130 IP=1,NPAS EXNL 38 IPAS=IPAS+1 EXNL 39 XPAS=XPAS+DPAS EXNL 40 WRITE(MP,2000) IPAS,DPAS,XPAS,NITER,IMETH,EPSDL,OMEGA EXNL 41 2000 FORMAT(/1X,13('-'),'PAS NUMERO (IPAS):',I5// EXNL 42 1 14X,'ACCROISSEMENT (DPAS)=',E12.5/ EXNL 43 2 14X,'NIVEAU TOTAL (XPAS)=',E12.5/ EXNL 44 3 14X,'NOMBRE D ITERATIONS (NITER)=',I12/ EXNL 45 4 14X,'METHODE NUMERO (IMETH):',I12/ EXNL 46 5 14X,'PRECISION (EPSDL)=',E12.5/ EXNL 47 6 14X,'FACTEUR DE SUR-RELAXATION (OMEGA)=',E12.5/) EXNL 48 C EXNL 49 C------- BOUCLE SUR LES ITERATIONS D'EQUILIBRE EXNL 50 C EXNL 51 DO 110 ITER=1,NITER EXNL 52 C------- CHOIX DE LA METHODE EXNL 53 IF(IMETH.GT.3) GO TO 20 EXNL 54 C------- METHODES DE TYPE NEWTON EXNL 55 CALL NEWTON(VCORG,KDLNC,VDIMP,KNEQ,KLD,KLOCE,VCORE,VPRNE,VPREE, EXNL 56 1 KNE,VKE,VME,VFE,VDLE,VKGS,VKGD,VKGI,VFG,VRES,VDLG) EXNL 57 GO TO 100 EXNL 58 C------- AUTRES METHODES ...... EXNL 59 20 CONTINUE EXNL 60 WRITE(MP,2010) IMETH EXNL 61 2010 FORMAT(' ** ERREUR, METHODE:',I3,' INCONNUE') EXNL 62 STOP EXNL 63 C------- CALCUL DE LA NORME EXNL 64 100 CALL NORME(NEQ,VRES,VDLG,XNORM) EXNL 65 IF(M.GT.0) WRITE(MP,2020) ITER,XNORM EXNL 66 2020 FORMAT(5X,'ITERATION (ITER):',I3,' NORME (XNORM)=',E12.5) EXNL 67 IF(M.GE.2) CALL PRSOL(KDLNC,VCORG,VDIMP,KNEQ,VDLG) EXNL 68 IF(XNORM.LE.EPSDL) GO TO 120 EXNL 69 110 CONTINUE EXNL 70 ITER=NITER EXNL 71 C------- FIN DU PAS EXNL 72 120 DPAS0=DPAS EXNL 73 WRITE(MP,2030) ITER,NITER EXNL 74 2030 FORMAT(/10X,I4,' ITERATIONS EFFECTUEES SUR',I4/) EXNL 75 IF(M.LT.2) CALL PRSOL(KDLNC,VCORG,VDIMP,KNEQ,VDLG) EXNL 76 130 CONTINUE EXNL 77 GO TO 10 EXNL 78 C------- SAUVEGARDE DE LA SOLUTION SUR FICHIER M4 EXNL 79 140 IF(M4.NE.0) WRITE(M4) (VDLG(I),I=1,NEQ) EXNL 80 RETURN EXNL 81 END EXNL 82 SUBROUTINE NEWTON(VCORG,KDLNC,VDIMP,KNEQ,KLD,KLOCE,VCORE,VPRNE, NEWT 1 1 VPREE,KNE,VKE,VME,VFE,VDLE,VKGS,VKGD,VKGI,VFG,VRES,VDLG) NEWT 2 C=======================================================================NEWT 3 C ALGORITHME DES METHODES DE TYPE NEWTON-RAPHSON NEWT 4 C IMETH.EQ.1 CALCUL DE K A CHAQUE ITERATION NEWT 5 C IMETH.EQ.2 K CONSTANTE NEWT 6 C IMETH.EQ.3 K RECALCULEE AU DEBUT DE CHAQUE PAS NEWT 7 C=======================================================================NEWT 8 IMPLICIT REAL*8(A-H,O-Z) NEWT 9 COMMON/ASSE/NSYM,NKG NEWT 10 COMMON/RESO/NEQ NEWT 11 COMMON/NLIN/EPSDL,XNORM,OMEGA,XPAS,DPAS,DPAS0,NPAS,IPAS,NITER, NEWT 12 1 ITER,IMETH NEWT 13 COMMON/ES/M,MR,MP NEWT 14 DIMENSION VCORG(1),KDLNC(1),VDIMP(1),KNEQ(1),KLD(1),KLOCE(1), NEWT 15 1 VCORE(1),VPRNE(1),VPREE(1),KNE(1),VKE(1),VME(1),VFE(1),VDLE(1), NEWT 16 2 VKGS(1),VKGD(1),VKGI(1),VFG(1),VRES(1),VDLG(1) NEWT 17 DATA ZERO/0.D0/,UN/1.D0/ NEWT 18 C-----------------------------------------------------------------------NEWT 19 C------- DECISION DE REASSEMBLAGE DE LA MATRICE GLOBALE NEWT 20 IKT=0 NEWT 21 IF(IMETH.EQ.1) GO TO 10 NEWT 22 IF(IPAS.EQ.1.AND.ITER.EQ.1) GO TO 10 NEWT 23 IF(IMETH.EQ.3.AND.ITER.EQ.1) GO TO 10 NEWT 24 GO TO 20 NEWT 25 10 IKT=1 NEWT 26 C------- INITIALISER A ZERO LA MATRICE GLOBALE SI ON DOIT L'ASSEMBLER NEWT 27 20 IF(IKT.EQ.0)GO TO 30 NEWT 28 CALL INIT(ZERO,NKG,VKGS) NEWT 29 CALL INIT(ZERO,NEQ,VKGD) NEWT 30 IF(NSYM.EQ.1) CALL INIT(ZERO,NKG,VKGI) NEWT 31 C------- PLACER LES SOLLICITATIONS DANS LE RESIDU NEWT 32 30 CALL MAJ(XPAS,ZERO,NEQ,VFG,VRES) NEWT 33 C------- ASSEMBLER LE RESIDU ET,EVENTUELLEMENT LA MATRICE GLOBALE NEWT 34 CALL ASNEWT(IKT,KLD,VDIMP,KLOCE,VCORE,VPRNE,VPREE,KNE,VKE,VFE, NEWT 35 1 VKGS,VKGD,VKGI,VDLG,VDLE,VRES) NEWT 36 C------- RESOLUTION NEWT 37 CALL SOL(VKGS,VKGD,VKGI,VRES,KLD,NEQ,MP,IKT,1,NSYM,ENERG) NEWT 38 IF(IKT.EQ.1.AND.M.GT.1) CALL PRPVTS(VKGD) NEWT 39 C------- MISE A JOUR DE LA SOLUTION NEWT 40 CALL MAJ(OMEGA,UN,NEQ,VRES,VDLG) NEWT 41 RETURN NEWT 42 END NEWT 43 SUBROUTINE ASNEWT(IKT,KLD,VDIMP,KLOCE,VCORE,VPRNE,VPREE, ASNE 1 1 KNE,VKE,VFE,VKGS,VKGD,VKGI,VFG,VDLE,VRES) ASNE 2 C=======================================================================ASNE 3 C ASSEMBLAGE DES RESIDUS ET DE LA MATRICE GLOBALE (SI IKT.EQ.1) ASNE 4 C DANS LA MEME BOUCLE SUR LES ELEMENTS (POUR LA METHODE DE NEWTON- ASNE 5 C RAPHSON) ASNE 6 C=======================================================================ASNE 7 IMPLICIT REAL*8(A-H,O-Z) ASNE 8 COMMON/ELEM/NELT,NNEL,NTPE,NGRE,ME,NIDENT ASNE 9 COMMON/ASSE/NSYM ASNE 10 COMMON/RESO/NEQ ASNE 11 COMMON/RGDT/IEL,ITPE,ITPE1,IGRE,IDLE,ICE,IPRNE,IPREE,INEL,IDEG,IPGASNE 12 1 ,ICOD ASNE 13 COMMON/ES/M,MR,MP,M1,M2 ASNE 14 DIMENSION KLD(1),VDIMP(1),KLOCE(1),VCORE(1),VPRNE(1),VPREE(1), ASNE 15 1 KNE(1),VKE(1),VFE(1),VKGS(1),VKGD(1),VKGI(1),VFG(1),VDLE(1), ASNE 16 2 VRES(1) ASNE 17 C-----------------------------------------------------------------------ASNE 18 C------- POSITIONNER AU DEBUT LE FICHIER DES ELEMENTS (M2) ASNE 19 REWIND M2 ASNE 20 C------- BOUCLE SUR LES ELEMENTS ASNE 21 DO 40 IE=1,NELT ASNE 22 C------- LIRE UN ELEMENT ASNE 23 CALL RDELEM(M2,KLOCE,VCORE,VPRNE,VPREE,KNE) ASNE 24 C------- CALCUL DES FONCTIONS D'INTERPOLATION SI NECESSAIRE ASNE 25 IF(ITPE.EQ.ITPE1) GO TO 10 ASNE 26 ICOD=2 ASNE 27 CALL ELEMLB(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ASNE 28 C------- EXTRAIRE LES D.L. DE L'ELEMENT DE VFG ASNE 29 10 CALL DLELM(KLOCE,VFG,VDIMP,VDLE) ASNE 30 C------- CALCULER LES RESIDUS ELEMENTAIRES ET CHANGER LEURS SIGNES ASNE 31 ICOD=6 ASNE 32 CALL ELEMLB(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ASNE 33 DO 20 I=1,IDLE ASNE 34 20 VFE(I)=-VFE(I) ASNE 35 C------- CALCUL DE LA MATRICE GLOBALE ASNE 36 IF(IKT.EQ.0) GO TO 30 ASNE 37 ICOD=4 ASNE 38 CALL ELEMLB(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ASNE 39 C------- ASSEMBLAGE DES RESIDUS ET DE LA MATRICE GLOBALE ASNE 40 30 CALL ASSEL(IKT,1,IDLE,NSYM,KLOCE,KLD,VKE,VFE,VKGS,VKGD,VKGI,VRES) ASNE 41 40 ITPE1=ITPE ASNE 42 RETURN ASNE 43 END ASNE 44 SUBROUTINE INIT(X,N,V) INIT 1 C=======================================================================INIT 2 C INITIALISATION DU VECTEUR V A LA VALEUR X INIT 3 C=======================================================================INIT 4 IMPLICIT REAL*8(A-H,O-Z) INIT 5 DIMENSION V(1) INIT 6 C-----------------------------------------------------------------------INIT 7 DO 10 I=1,N INIT 8 10 V(I)=X INIT 9 RETURN INIT 10 END INIT 11 SUBROUTINE MAJ(X1,X2,N,V1,V2) MAJ 1 C=======================================================================MAJ 2 C EXECUTION DE L'OPERATION VECTORIELLE: V2=X1*V1 + X2*V2 MAJ 3 C X1,X2:SCALAIRES V1,V2:VECTEURS MAJ 4 C=======================================================================MAJ 5 IMPLICIT REAL*8(A-H,O-Z) MAJ 6 DIMENSION V1(1),V2(1) MAJ 7 C-----------------------------------------------------------------------MAJ 8 DO 10 I=1,N MAJ 9 10 V2(I)=X1*V1(I)+X2*V2(I) MAJ 10 RETURN MAJ 11 END MAJ 12 SUBROUTINE NORME(N,VDEL,V,XNORM) NORM 1 C=======================================================================NORM 2 C CALCUL DU RAPPORT DES LONGUEURS DES VECTEURS VDEL ET V NORM 3 C=======================================================================NORM 4 IMPLICIT REAL*8(A-H,O-Z) NORM 5 DIMENSION VDEL(1),V(1) NORM 6 DATA ZERO/0.D0/,UN/1.D0/,FAC/1.D-3/ NORM 7 SQRT(X)=DSQRT(X) NORM 8 C-----------------------------------------------------------------------NORM 9 C1=ZERO NORM 10 C2=ZERO NORM 11 DO 10 I=1,N NORM 12 C1=C1+VDEL(I)*VDEL(I) NORM 13 10 C2=C2+V(I)*V(I) NORM 14 C=C1*FAC NORM 15 IF(C2.LE.C) C2=UN NORM 16 XNORM=SQRT(C1/C2) NORM 17 RETURN NORM 18 END NORM 19 C++++++ FIN FIGURE 6.24 C++++++ DEBUT FIGURE 6.25 SUBROUTINE BLTEMP BLTE 1 C=======================================================================BLTE 2 C APPEL DU BLOC 'TEMP' BLTE 3 C RESOLUTION D'UN PROBLEME NON STATIONNAIRE LINEAIRE OU NON BLTE 4 C=======================================================================BLTE 5 IMPLICIT REAL*8(A-H,O-Z) BLTE 6 REAL*4 TBL BLTE 7 COMMON/ELEM/NUL(4),ME BLTE 8 COMMON/ASSE/NSYM,NKG,NKE,NDLE BLTE 9 COMMON/RESO/NEQ BLTE 10 COMMON/NLIN/EPSDL,XNORM,OMEGA,XPAS,DPAS,DPAS0,NPAS,IPAS,NITER, BLTE 11 1 ITER,IMETH BLTE 12 COMMON/ES/M,MR,MP,M1,M2,M3,M4 BLTE 13 COMMON/LOC/LCORG,LDLNC,LNEQ,LDIMP,LPRNG,LPREG,LLD,LLOCE,LCORE,LNE,BLTE 14 1 LPRNE,LPREE,LDLE,LKE,LFE,LKGS,LKGD,LKGI,LFG,LRES,LDLG,LME, BLTE 15 1 LDLE0,LDLG0,LFG0 BLTE 16 COMMON VA(1) BLTE 17 DIMENSION TBL(13),IN(2),XIN(3) BLTE 18 DATA TBL/4HKGS ,4HKGD ,4HKGI ,4HFG ,4HKE , BLTE 19 1 4HFE ,4HRES ,4HDLE ,4HDLG ,4HME ,4HDLE0,4HDLG0,4HFG0 / BLTE 20 C-----------------------------------------------------------------------BLTE 21 IF(M1.EQ.0) M1=MR BLTE 22 IF(M2.EQ.0) M2=ME BLTE 23 WRITE(MP,2000) M BLTE 24 2000 FORMAT(//' RESOLUTION NON STATIONNAIRE (M=',I2,')'/1X,23('=')) BLTE 25 C------- ALLOCATION D'ESPACE BLTE 26 IF(LKGS.EQ.1) CALL ESPACE(NKG,1,TBL(1),LKGS) BLTE 27 IF(LKGD.EQ.1) CALL ESPACE(NEQ,1,TBL(2),LKGD) BLTE 28 IF(NSYM.EQ.1.AND.LKGI.EQ.1) CALL ESPACE(NKG,1,TBL(3),LKGI) BLTE 29 IF(LFG.EQ.1) CALL ESPACE (NEQ,1,TBL(4),LFG) BLTE 30 IF(LKE.EQ.1) CALL ESPACE(NKE,1,TBL(5),LKE) BLTE 31 IF(LFE.EQ.1) CALL ESPACE(NDLE,1,TBL(6),LFE) BLTE 32 IF(LRES.EQ.1) CALL ESPACE(NEQ,1,TBL(7),LRES) BLTE 33 IF(LDLE.EQ.1) CALL ESPACE(NDLE,1,TBL(8),LDLE) BLTE 34 IF(LDLG.EQ.1) CALL ESPACE(NEQ,1,TBL(9),LDLG) BLTE 35 IF(LME.EQ.1) CALL ESPACE(NKE,1,TBL(10),LME) BLTE 36 IF(LDLE0.EQ.1) CALL ESPACE(NDLE,1,TBL(11),LDLE0) BLTE 37 IF(LDLG0.EQ.1) CALL ESPACE(NEQ,1,TBL(12),LDLG0) BLTE 38 IF(LFG0.EQ.1) CALL ESPACE(NEQ,1,TBL(13),LFG0) BLTE 39 C------- EXECUTION DU BLOC BLTE 40 CALL EXTEMP(VA(LCORG),VA(LDLNC),VA(LDIMP),VA(LNEQ),VA(LLD), BLTE 41 1 VA(LLOCE),VA(LCORE),VA(LPRNE),VA(LPREE),VA(LNE),VA(LKE),VA(LME),BLTE 42 2 VA(LFE),VA(LDLE),VA(LKGS),VA(LKGD),VA(LKGI),VA(LFG),VA(LRES), BLTE 43 3 VA(LDLG),VA(LDLE0),VA(LDLG0),VA(LFG0)) BLTE 44 RETURN BLTE 45 END BLTE 46 SUBROUTINE EXTEMP(VCORG,KDLNC,VDIMP,KNEQ,KLD,KLOCE,VCORE,VPRNE, EXTE 1 1 VPREE,KNE,VKE,VME,VFE,VDLE,VKGS,VKGD,VKGI,VFG,VRES,VDLG, EXTE 2 2 VDLE0,VDLG0,VFG0) EXTE 3 C=======================================================================EXTE 4 C EXECUTION DU BLOC 'TEMP' EXTE 5 C RESOLUTION D'UN PROBLEME NON STATIONNAIRE LINEAIRE OU NON EXTE 6 C=======================================================================EXTE 7 IMPLICIT REAL*8(A-H,O-Z) EXTE 8 COMMON/RESO/NEQ EXTE 9 COMMON/COND/NCLT,NCLZ,NCLNZ EXTE 10 COMMON/ASSE/NSYM EXTE 11 COMMON/NLIN/EPSDL,XNORM,OMEGA,XPAS,DPAS,DPAS0,NPAS,IPAS,NITER, EXTE 12 1 ITER,IMETH EXTE 13 COMMON/ES/M,MR,MP,M1,M2,M3,M4 EXTE 14 DIMENSION VCORG(1),KDLNC(1),VDIMP(1),KNEQ(1),KLD(1),KLOCE(1), EXTE 15 1 VCORE(1),VPRNE(1),VPREE(1),KNE(1),VKE(1),VME(1),VFE(1),VDLE(1), EXTE 16 2 VKGS(1),VKGD(1),VKGI(1),VFG(1),VRES(1),VDLG(1),VDLE0(1), EXTE 17 3 VDLG0(1),VFG0(1) EXTE 18 DATA ZERO/0.D0/,UN/1.D0/ EXTE 19 C-----------------------------------------------------------------------EXTE 20 DPAS0=ZERO EXTE 21 XPAS=ZERO EXTE 22 IPAS=0 EXTE 23 C------- LECTURE DES DEGRES DE LIBERTE INITIAUX SUR LE FICHIER M3 EXTE 24 IF(M3.EQ.0) GO TO 5 EXTE 25 REWIND M3 EXTE 26 READ(M3) (VDLG(I),I=1,NEQ) EXTE 27 CALL MAJ(UN,ZERO,NEQ,VDLG,VDLG0) EXTE 28 C------- SAUVER L'ETAT DE SOLLICITATION DE REFERENCE EXTE 29 5 CALL MAJ(UN,ZERO,NEQ,VFG,VFG0) EXTE 30 C------- LIRE UNE CARTE DEFINISSANT UN ENSEMBLE DE PAS IDENTIQUES EXTE 31 10 READ(M1,1000) DPAS,I1,I2,I3,X1,X2 EXTE 32 1000 FORMAT(F10.0,3I5,2F10.0) EXTE 33 IF(DPAS.EQ.ZERO) GO TO 140 EXTE 34 IF(I1.GT.0) NPAS=I1 EXTE 35 IF(I2.GT.0) NITER=I2 EXTE 36 IF(I3.GT.0) IMETH=I3 EXTE 37 IF(X1.GT.ZERO) EPSDL=X1 EXTE 38 IF(X2.NE.ZERO) OMEGA=X2 EXTE 39 C EXTE 40 C------- BOUCLE SUR LES PAS EXTE 41 C EXTE 42 DO 130 IP=1,NPAS EXTE 43 CALL INIT(ZERO,NEQ,VFG) EXTE 44 IPAS=IPAS+1 EXTE 45 XPAS=XPAS+DPAS EXTE 46 WRITE(MP,2000) IPAS,DPAS,XPAS,NITER,IMETH,EPSDL,OMEGA EXTE 47 2000 FORMAT(/1X,13('-'),'PAS NUMERO (IPAS):',I5// EXTE 48 1 14X,'ACCROISSEMENT (DPAS)=',E12.5/ EXTE 49 2 14X,'NIVEAU TOTAL (XPAS)=',E12.5/ EXTE 50 3 14X,'NOMBRE D ITERATIONS (NITER)=',I12/ EXTE 51 4 14X,'METHODE NUMERO (IMETH):',I12/ EXTE 52 5 14X,'PRECISION (EPSDL)=',E12.5/ EXTE 53 6 14X,'COEFFICIENT ALPHA (OMEGA)=',E12.5/) EXTE 54 C EXTE 55 C------- BOUCLE SUR LES ITERATIONS D'EQUILIBRE EXTE 56 C EXTE 57 DO 110 ITER=1,NITER EXTE 58 C------- CHOIX DE LA METHODE EXTE 59 IF(IMETH.GT.3) GO TO 20 EXTE 60 C------- METHODES DE TYPE EULER EXTE 61 CALL EULER(VCORG,KDLNC,VDIMP,KNEQ,KLD,KLOCE,VCORE,VPRNE,VPREE, EXTE 62 1 KNE,VKE,VME,VFE,VDLE,VKGS,VKGD,VKGI,VFG,VRES,VDLG, EXTE 63 2 VDLE0,VDLG0,VFG0) EXTE 64 GO TO 100 EXTE 65 C------- AUTRES METHODES ...... EXTE 66 20 CONTINUE EXTE 67 WRITE(MP,2010) IMETH EXTE 68 2010 FORMAT(' ** ERREUR, METHODE:',I3,' INCONNUE') EXTE 69 STOP EXTE 70 C------- CALCUL DE LA NORME EXTE 71 100 CALL NORME(NEQ,VRES,VDLG,XNORM) EXTE 72 IF(M.GT.0) WRITE(MP,2020) ITER,XNORM EXTE 73 2020 FORMAT(5X,'ITERATION (ITER):',I3,' NORME (XNORM)=',E12.5) EXTE 74 IF(M.GE.2) CALL PRSOL(KDLNC,VCORG,VDIMP,KNEQ,VDLG) EXTE 75 IF(XNORM.LE.EPSDL) GO TO 120 EXTE 76 110 CONTINUE EXTE 77 C------- FIN DU PAS EXTE 78 120 DPAS0=DPAS EXTE 79 CALL MAJ(UN,ZERO,NEQ,VDLG,VDLG0) EXTE 80 CALL PRSOL(KDLNC,VCORG,VDIMP,KNEQ,VDLG) EXTE 81 130 CONTINUE EXTE 82 GO TO 10 EXTE 83 C------- SAUVEGARDE DE LA SOLUTION SUR FICHIER M4 EXTE 84 140 IF(M4.NE.0) WRITE(M4) (VDLG(I),I=1,NEQ) EXTE 85 RETURN EXTE 86 END EXTE 87 SUBROUTINE EULER(VCORG,KDLNC,VDIMP,KNEQ,KLD,KLOCE,VCORE,VPRNE, EULE 1 1 VPREE,KNE,VKE,VME,VFE,VDLE,VKGS,VKGD,VKGI,VFG,VRES,VDLG, EULE 2 2 VDLE0,VDLG0,VFG0) EULE 3 C=======================================================================EULE 4 C ALGORITHME DES METHODES DE TYPE EULER (IMPLICITE,EXPLICITE OU EULE 5 C MIXTE SELON OMEGA) POUR DES PROBLEMES LINEAIRES OU NON LINEAIRES EULE 6 C LE PROBLEME NON LINEAIRE EST RESOLU PAR UNE METHODE DE TYPE EULE 7 C NEWTON-RAPHSON EULE 8 C IMETH.EQ.1 NEWTON-RAPHSON STANDARD EULE 9 C IMETH.EQ.2 K CONSTANTE EULE 10 C IMETH.EQ.3 K RECALCULEE AU DEBUT DE CHAQUE PAS EULE 11 C=======================================================================EULE 12 IMPLICIT REAL*8(A-H,O-Z) EULE 13 COMMON/ASSE/NSYM,NKG EULE 14 COMMON/RESO/NEQ EULE 15 COMMON/NLIN/EPSDL,XNORM,OMEGA,XPAS,DPAS,DPAS0,NPAS,IPAS,NITER, EULE 16 1 ITER,IMETH EULE 17 COMMON/ES/M,MR,MP EULE 18 DIMENSION VCORG(1),KDLNC(1),VDIMP(1),KNEQ(1),KLD(1),KLOCE(1), EULE 19 1 VCORE(1),VPRNE(1),VPREE(1),KNE(1),VKE(1),VME(1),VFE(1), EULE 20 2 VDLE(1),VKGS(1),VKGD(1),VKGI(1),VFG(1),VRES(1),VDLG(1), EULE 21 3 VDLE0(1),VDLG0(1),VFG0(1) EULE 22 DATA ZERO/0.D0/,UN/1.D0/ EULE 23 C-----------------------------------------------------------------------EULE 24 C------- DECISION DE REASSEMBLAGE DE LA MATRICE GLOBALE EULE 25 IKT=0 EULE 26 IF(IMETH.EQ.1) GO TO 10 EULE 27 IF(DPAS.NE.DPAS0.AND.ITER.EQ.1) GO TO 10 EULE 28 IF(IMETH.EQ.3.AND.ITER.EQ.1) GO TO 10 EULE 29 GO TO 20 EULE 30 10 IKT=1 EULE 31 C------- INITIALISER A ZERO LA MATRICE GLOBALE SI NECESSAIRE EULE 32 20 IF(IKT.EQ.0) GO TO 30 EULE 33 CALL INIT(ZERO,NKG,VKGS) EULE 34 CALL INIT(ZERO,NEQ,VKGD) EULE 35 IF(NSYM.EQ.1) CALL INIT(ZERO,NKG,VKGI) EULE 36 C------- ASSEMBLAGE DES RESIDUS ET DE LA MATRICE GLOBALE SI NECESSAIRE EULE 37 30 CALL MAJ(UN,ZERO,NEQ,VFG0,VRES) EULE 38 CALL ASEULR(IKT,VCORG,KDLNC,VDIMP,KNEQ,KLD,KLOCE,VCORE,VPRNE, EULE 39 1 VPREE,KNE,VKE,VME,VFE,VDLE,VKGS,VKGD,VKGI,VFG,VRES,VDLG, EULE 40 2 VDLE0,VDLG0,VFG0) EULE 41 C1=UN EULE 42 IF(ITER.GT.1) C1=C1-OMEGA EULE 43 DO 40 I=1,NEQ EULE 44 40 VRES(I)=DPAS*(VRES(I)-C1*VFG(I)) EULE 45 C------- RESOLUTION EULE 46 CALL SOL(VKGS,VKGD,VKGI,VRES,KLD,NEQ,MP,IKT,1,NSYM,ENERG) EULE 47 C------- MISE A JOUR DE LA SOLUTION EULE 48 CALL MAJ(UN,UN,NEQ,VRES,VDLG) EULE 49 RETURN EULE 50 END EULE 51 SUBROUTINE ASEULR(IKT,VCORG,KDLNC,VDIMP,KNEQ,KLD,KLOCE,VCORE, ASEU 1 1 VPRNE,VPREE,KNE,VKE,VME,VFE,VDLE,VKGS,VKGD,VKGI,VFG,VRES, ASEU 2 2 VDLG,VDLE0,VDLG0,VFG0) ASEU 3 C=======================================================================ASEU 4 C ASSEMBLAGE DES RESIDUS ET DE LA MATRICE GLOBALE (SI IKT.EQ.1) ASEU 5 C DANS LA MEME BOUCLE SUR LES ELEMENTS (POUR LA METHODE DE EULER) ASEU 6 C=======================================================================ASEU 7 IMPLICIT REAL*8(A-H,O-Z) ASEU 8 COMMON/ELEM/NELT,NNEL,NTPE,NGRE,ME,NIDENT ASEU 9 COMMON/ASSE/NSYM ASEU 10 COMMON/RESO/NEQ ASEU 11 COMMON/RGDT/IEL,ITPE,ITPE1,IGRE,IDLE,ICE,IPRNE,IPREE,INEL,IDEG,IPGASEU 12 1 ,ICOD ASEU 13 COMMON/NLIN/EPSDL,XNORM,OMEGA,XPAS,DPAS,DPAS0,NPAS,IPAS,NITER, ASEU 14 1 ITER,IMETH ASEU 15 COMMON/ES/M,MR,MP,M1,M2 ASEU 16 DIMENSION VCORG(1),KDLNC(1),VDIMP(1),KNEQ(1),KLD(1),KLOCE(1), ASEU 17 1 VCORE(1),VPRNE(1),VPREE(1),KNE(1),VKE(1),VME(1),VFE(1),VDLE(1), ASEU 18 2 VKGS(1),VKGD(1),VKGI(1),VFG(1),VRES(1),VDLG(1),VDLE0(1), ASEU 19 3 VDLG0(1),VFG0(1) ASEU 20 DATA UN/1.D0/ ASEU 21 C-----------------------------------------------------------------------ASEU 22 CC=DPAS*OMEGA ASEU 23 IFE=0 ASEU 24 IF(ITER.GT.1) IFE=1 ASEU 25 C------- POSITIONNER AU DEBUT LE FICHIER DES ELEMENTS (ME) ASEU 26 REWIND M2 ASEU 27 C------- BOUCLE SUR LES ELEMENTS ASEU 28 DO 90 IE=1,NELT ASEU 29 C------- LIRE UN ELEMENT ASEU 30 CALL RDELEM(M2,KLOCE,VCORE,VPRNE,VPREE,KNE) ASEU 31 C------- CALCUL DES FONCTIONS D'INTERPOLATION SI NECESSAIRE ASEU 32 IF(ITPE.EQ.ITPE1) GO TO 10 ASEU 33 ICOD=2 ASEU 34 CALL ELEMLB(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ASEU 35 C------- EXTRAIRE LES D.L. DE L'ELEMENT DE VFG ASEU 36 10 CALL DLELM(KLOCE,VDLG,VDIMP,VDLE) ASEU 37 C------- CALCUL DU RESIDU K.U ASEU 38 ICOD=6 ASEU 39 CALL ELEMLB(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ASEU 40 C------- CALCUL DE LA MATRICE M ASEU 41 ICOD=5 ASEU 42 CALL ELEMLB(VCORE,VPRNE,VPREE,VDLE,VME,VFE) ASEU 43 C------- CALCUL DE LA MATRICE K SI NECESSAIRE ASEU 44 IF(IKT.EQ.0) GO TO 15 ASEU 45 ICOD=3 ASEU 46 CALL ELEMLB(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ASEU 47 C------- RESIDUS A LA PREMIERE ITERATION DE CHAQUE PAS (LINEAIRE) ASEU 48 15 IF(ITER.GT.1) GO TO 20 ASEU 49 CALL ASSEL(0,1,IDLE,NSYM,KLOCE,KLD,VKE,VFE,VKGS,VKGD,VKGI,VFG) ASEU 50 GO TO 60 ASEU 51 C------- RESIDUS APRES LA PREMIERE ITERATION ASEU 52 20 CALL DLELM(KLOCE,VDLG0,VDIMP,VDLE0) ASEU 53 DO 30 I=1,IDLE ASEU 54 VDLE(I)=(VDLE0(I)-VDLE(I))/DPAS ASEU 55 30 VFE(I)=-OMEGA*VFE(I) ASEU 56 C------- PRODUIT M . U ASEU 57 VFE(1)=VFE(1)+VME(1)*VDLE(1) ASEU 58 II=1 ASEU 59 DO 50 J=2,IDLE ASEU 60 J1=J-1 ASEU 61 DO 40 I=1,J1 ASEU 62 II=II+1 ASEU 63 VFE(I)=VFE(I)+VME(II)*VDLE(J) ASEU 64 40 VFE(J)=VFE(J)+VME(II)*VDLE(I) ASEU 65 II=II+1 ASEU 66 50 VFE(J)=VFE(J)+VME(II)*VDLE(J) ASEU 67 C------- MATRICE M + DPAS.OMEGA. K ASEU 68 60 IF(IKT.EQ.0) GO TO 80 ASEU 69 II=0 ASEU 70 DO 70 I=1,IDLE ASEU 71 DO 70 J=I,IDLE ASEU 72 II=II+1 ASEU 73 70 VKE(II)=VKE(II)*CC+VME(II) ASEU 74 C------- ASSEMBLAGE DU RESIDU ET DE LA MATRICE GLOBALE ASEU 75 80 CALL ASSEL(IKT,IFE,IDLE,NSYM,KLOCE,KLD,VKE,VFE,VKGS,VKGD,VKGI, ASEU 76 1 VRES) ASEU 77 90 ITPE1=ITPE ASEU 78 RETURN ASEU 79 END ASEU 80 C++++++ FIN FIGURE 6.25 C++++++ DEBUT FIGURE 6.26 SUBROUTINE BLVALP BLVA 1 C=======================================================================BLVA 2 C APPEL DU BLOC 'VALP' BLVA 3 C CALCUL DES VALEURS ET VECTEURS PROPRES PAR ITERATION SUR UN BLVA 4 C SOUS-ESPACE BLVA 5 C=======================================================================BLVA 6 IMPLICIT REAL*8(A-H,O-Z) BLVA 7 REAL*4 TBL BLVA 8 COMMON/ELEM/NUL(4),ME BLVA 9 COMMON/ASSE/NSYM,NKG,NKE,NDLE BLVA 10 COMMON/RESO/NEQ BLVA 11 COMMON/VALP/NITER,NMDIAG,EPSLB,SHIFT,NSS,NSWM,TOLJAC,NVALP BLVA 12 COMMON/ES/M,MR,MP,M1,M2 BLVA 13 COMMON/LOC/LCORG,LDLNC,LNEQ,LDIMP,LPRNG,LPREG,LLD,LLOCE,LCORE,LNE,BLVA 14 1 LPRNE,LPREE,LDLE,LKE,LFE,LKGS,LKGD,LKGI,LFG,LRES,LDLG BLVA 15 COMMON/TRVL/X1,X2,X3,I1,I2,I3,I4,I5 BLVA 16 COMMON VA(1) BLVA 17 DIMENSION TBL(20) BLVA 18 DATA TBL/4HKGS ,4HKGD ,4HMGS ,4HMGD ,4HFG ,4HKE ,4HFE ,4HDLE , BLVA 19 1 4HRES ,4HDLG ,4HP ,4HLAMB,4HLAM1,4HR ,4HPHI ,4HKSS ,4HMSS , BLVA 20 1 4HV1 ,4HVX ,4HV2 /,ZERO/0.D0/ BLVA 21 C-----------------------------------------------------------------------BLVA 22 IF(M1.EQ.0) M1=MR BLVA 23 IF(M2.EQ.0) M2=ME BLVA 24 READ(M1,1000) I1,I2,X1,X2,I3,I4,I5,X3 BLVA 25 1000 FORMAT(2I5,2F10.0,3I5,1F10.0) BLVA 26 IF(I1.NE.0) NVALP=I1 BLVA 27 IF(I2.NE.0) NITER=I2 BLVA 28 NSS=I3 BLVA 29 IF(I4.NE.0) NMDIAG=I4 BLVA 30 IF(I5.NE.0) NSWM=I5 BLVA 31 IF(X1.NE.ZERO) EPSLB=X1 BLVA 32 IF(X2.NE.ZERO) SHIFT=X2 BLVA 33 IF(X3.NE.ZERO) TOLJAC=X3 BLVA 34 IF(NSS.NE.0) GO TO 10 BLVA 35 NSS=MIN0(NVALP+8,2*NVALP) BLVA 36 NSS=MIN0(NSS,NEQ) BLVA 37 10 CONTINUE BLVA 38 WRITE(MP,2000) M,NVALP,NITER,NMDIAG,EPSLB,SHIFT,NSS,NSWM,TOLJAC BLVA 39 2000 FORMAT(//' ITERATION PAR SOUS-ESPACE (M=',I2,')'/' ',26('=')/ BLVA 40 1 15X,'NOMBRE DE VALEURS PROPRES DESIREES (NVALP)=',I12/ BLVA 41 2 15X,'NOMBRE D ITERATIONS MAX. (NITER)=',I12/ BLVA 42 3 15X,'INDICE DE MASSE DIAGONALE (NMDIAG)=',I12/ BLVA 43 4 15X,'PRECISION SUR LES VALEURS PROPRES (EPSLB)=',E12.5/ BLVA 44 5 15X,'DECALAGE (SHIFT)=',E12.5/ BLVA 45 6 15X,'DIMENSION DU SOUS-ESPACE (NSS)=',I12/ BLVA 46 7 15X,'NOMBRE MAX. D ITERATIONS DANS JACOBI (NSWM)=',I12/ BLVA 47 8 15X,'TOLERANCE DANS JACOBI (TOLJAC)=',1E12.5/)BLVA 48 IF(LKGS.EQ.1) CALL ESPACE(NKG,1,TBL(1),LKGS) BLVA 49 IF(LKGD.EQ.1) CALL ESPACE(NEQ,1,TBL(2),LKGD) BLVA 50 CALL ESPACE(NKG,1,TBL(3),LMGS) BLVA 51 CALL ESPACE(NEQ,1,TBL(4),LMGD) BLVA 52 IF(LFG.EQ.1) CALL ESPACE(NEQ,1,TBL(5),LFG) BLVA 53 IF(LKE.EQ.1) CALL ESPACE(NKE,1,TBL(6),LKE) BLVA 54 IF(LFE.EQ.1) CALL ESPACE(NDLE,1,TBL(7),LFE) BLVA 55 IF(LDLE.EQ.1) CALL ESPACE(NDLE,1,TBL(8),LDLE) BLVA 56 IF(LRES.EQ.1) CALL ESPACE(NEQ,1,TBL(9),LRES) BLVA 57 IF(LDLG.EQ.1) CALL ESPACE(NEQ,1,TBL(10),LDLG) BLVA 58 CALL ESPACE(NEQ*NSS,1,TBL(11),LVEC) BLVA 59 CALL ESPACE(NSS,1,TBL(12),LLAMB) BLVA 60 CALL ESPACE(NSS,1,TBL(13),LLAM1) BLVA 61 CALL ESPACE(NSS*(NSS+1)/2,1,TBL(16),LKSS) BLVA 62 CALL ESPACE(NSS*(NSS+1)/2,1,TBL(17),LMSS) BLVA 63 CALL ESPACE(NEQ,1,TBL(18),LV1) BLVA 64 CALL ESPACE(NSS*NSS,1,TBL(19),LX) BLVA 65 CALL EXVALP(VA(LLD),VA(LDIMP),VA(LLOCE),VA(LCORE),VA(LPRNE), BLVA 66 1 VA(LPREE),VA(LNE),VA(LFE),VA(LKE),VA(LKGS),VA(LKGD),VA(LFG), BLVA 67 2 VA(LCORG),VA(LDLNC),VA(LNEQ),VA(LRES),VA(LDLE),VA(LDLG), BLVA 68 3 VA(LMGS),VA(LMGD),VA(LVEC),VA(LLAMB),VA(LLAM1),VA(LKSS),VA(LMSS)BLVA 69 4 ,VA(LV1),VA(LX),NEQ,NSS) BLVA 70 RETURN BLVA 71 END BLVA 72 SUBROUTINE EXVALP(KLD,VDIMP,KLOCE,VCORE,VPRNE,VPREE,KNE,VFE,VKE, EXVA 1 1 VKGS,VKGD,VFG,VCORG,KDLNC,KNEQ,VRES,VDLE,VDLG,VMGS,VMGD, EXVA 2 2 VEC,VLAMB,VLAM1,VKSS,VMSS,V1,VX,NEQ,NSS) EXVA 3 C=======================================================================EXVA 4 C EXECUTION DU BLOC 'VALP' EXVA 5 C CALCUL DES VALEURS ET VECTEURS PROPRES PAR ITERATION SUR UN EXVA 6 C SOUS-ESPACE EXVA 7 C=======================================================================EXVA 8 IMPLICIT REAL*8(A-H,O-Z) EXVA 9 COMMON/ASSE/NSYM,NKG,NKE,NDLE EXVA 10 COMMON/VALP/NITER,NMDIAG,EPSLB,SHIFT,NSS1,NSWM,TOLJAC,NVALP EXVA 11 COMMON/ES/M,MR,MP EXVA 12 DIMENSION KLD(1),VDIMP(1),KLOCE(1),VCORE(1),VPRNE(1),VPREE(1), EXVA 13 1 KNE(1),VFE(1),VKE(1),VKGS(1),VKGD(1),VFG(1),VCORG(1),KDLNC(1), EXVA 14 2 KNEQ(1),VRES(1),VDLE(1),VDLG(1),VMGS(1),VMGD(1),VEC(NEQ,1), EXVA 15 3 VLAMB(1),VLAM1(1),VKSS(1),VMSS(1),V1(1),VX(NSS,1) EXVA 16 DATA ZERO/0.D0/,UN/1.0D0/ EXVA 17 ABS(X)=DABS(X) EXVA 18 C-----------------------------------------------------------------------EXVA 19 C EXVA 20 C------- CALCULS PRELIMINAIRES EXVA 21 C EXVA 22 C------- ASSEMBLER KG ET MG EXVA 23 CALL ASKG(KLD,VDIMP,KLOCE,VCORE,VPRNE,VPREE,KNE,VKE,VFE,VKGS,VKGD,EXVA 24 1 VKGI,VFG,VDLE,VRES) EXVA 25 CALL ASMG(KLD,VDIMP,KLOCE,VCORE,VPRNE,VPREE,KNE,VKE,VFE,VMGS, EXVA 26 1 VMGD,VMGS,VFG,VDLE,VRES) EXVA 27 C------- TRIANGULARISER KG EXVA 28 CALL SOL(VKGS,VKGD,VKGI,VFG,KLD,NEQ,MP,1,0,0,ENERG) EXVA 29 C------- VECTEUR DES SOLLICITATIONS EGAL A LA DIAGONALE DE M EXVA 30 CMAX=ZERO EXVA 31 DO 10 ID=1,NEQ EXVA 32 C=VKGD(ID)/VMGD(ID) EXVA 33 V1(ID)=C EXVA 34 IF(C.GT.CMAX) CMAX=C EXVA 35 VEC(ID,1)=VMGD(ID) EXVA 36 DO 10 JS=2,NSS EXVA 37 10 VEC(ID,JS)=ZERO EXVA 38 C------- VECTEURS DES SOLLICITATIONS UNITES CORRESPONDANTS AUX MIN. DE EXVA 39 C K(I,I)/M(I,I) EXVA 40 DO 30 JS=2,NSS EXVA 41 C=CMAX EXVA 42 DO 20 ID=1,NEQ EXVA 43 IF(V1(ID).GT.C) GO TO 20 EXVA 44 C=V1(ID) EXVA 45 II=ID EXVA 46 20 CONTINUE EXVA 47 V1(II)=CMAX EXVA 48 VEC(II,JS)=UN EXVA 49 30 VLAMB(JS)=UN EXVA 50 VLAMB(1)=UN EXVA 51 C EXVA 52 C------- DEBUT DES ITERATIONS EXVA 53 C EXVA 54 ITERM=0 EXVA 55 ITMAX=NITER+1 EXVA 56 DO 200 ITER=1,ITMAX EXVA 57 C------- CALCUL DES VECTEURS DE RITZ EXVA 58 II0=0 EXVA 59 DO 80 JS=1,NSS EXVA 60 II0=II0+JS EXVA 61 DO 40 ID=1,NEQ EXVA 62 40 V1(ID)=VEC(ID,JS) EXVA 63 CALL SOL(VKGS,VKGD,VKGI,V1,KLD,NEQ,MP,0,1,0,ENERG) EXVA 64 C------- CALCUL DE LA PROJECTION DE K EXVA 65 II=II0 EXVA 66 DO 60 IS=JS,NSS EXVA 67 C=ZERO EXVA 68 DO 50 ID=1,NEQ EXVA 69 50 C=C+V1(ID)*VEC(ID,IS) EXVA 70 VKSS(II)=C EXVA 71 60 II=II+IS EXVA 72 DO 70 ID=1,NEQ EXVA 73 70 VEC(ID,JS)=V1(ID) EXVA 74 80 CONTINUE EXVA 75 C------- PROJECTION DE LA MATRICE M EXVA 76 II0=0 EXVA 77 DO 120 JS=1,NSS EXVA 78 II0=II0+JS EXVA 79 DO 85 ID=1,NEQ EXVA 80 85 V1(ID)=ZERO EXVA 81 CALL MULKU(VMGS,VMGD,VMGS,KLD,VEC(1,JS),NEQ,0,V1) EXVA 82 II=II0 EXVA 83 DO 100 IS=JS,NSS EXVA 84 C=ZERO EXVA 85 DO 90 ID=1,NEQ EXVA 86 90 C=C+V1(ID)*VEC(ID,IS) EXVA 87 IF(ITERM.GT.0) GO TO 120 EXVA 88 VMSS(II)=C EXVA 89 100 II=II+IS EXVA 90 DO 110 ID=1,NEQ EXVA 91 110 VEC(ID,JS)=V1(ID) EXVA 92 120 CONTINUE EXVA 93 C------- CALCUL DES VECTEURS PROPRES DANS LE SOUS-ESPACE EXVA 94 CALL JACOBI(VKSS,VMSS,NSS,NSWM,TOLJAC,V1,VLAM1,VX) EXVA 95 C------- NOUVEAU VECTEUR SOLLICITATIONS EXVA 96 DO 160 ID=1,NEQ EXVA 97 DO 130 JS=1,NSS EXVA 98 130 V1(JS)=VEC(ID,JS) EXVA 99 DO 150 JS=1,NSS EXVA 100 C=ZERO EXVA 101 DO 140 IS=1,NSS EXVA 102 140 C=C+V1(IS)*VX(IS,JS) EXVA 103 150 VEC(ID,JS)=C EXVA 104 160 CONTINUE EXVA 105 C------- IMPRESSION DE L ITERATION EXVA 106 IF(M.LT.1) GO TO 180 EXVA 107 WRITE(MP,2000) ITER EXVA 108 2000 FORMAT(//' . . . . . . ITERATION ',I5/) EXVA 109 DO 170 IS=1,NSS EXVA 110 WRITE(MP,2010) IS,VLAM1(IS) EXVA 111 2010 FORMAT(/' VALEUR PROPRE NO. ',I5,' =',E12.5//' VECTEUR PROPRE:') EXVA 112 170 CALL PRSOL(KDLNC,VCORG,VDIMP,KNEQ,VEC(1,IS)) EXVA 113 C------- TEST DE CONVERGENCE EXVA 114 180 IF(ITERM.GT.0) GO TO 210 EXVA 115 C=ZERO EXVA 116 IEX=0 EXVA 117 DO 190 IS=1,NSS EXVA 118 C1=ABS((VLAM1(IS)-VLAMB(IS))/VLAMB(IS)) EXVA 119 IF(C1.GT.C) C=C1 EXVA 120 IF(C1.LE.EPSLB) IEX=IEX+1 EXVA 121 190 CONTINUE EXVA 122 WRITE(MP,2015) ITER,C,IEX EXVA 123 2015 FORMAT(' ITERATION ',I4,' ERREUR MAX.=',E9.1,' VALEURS PROPRES EXEXVA 124 1ACTES:',I4) EXVA 125 IF(IEX.GE.NVALP) ITERM=1 EXVA 126 C------- NON CONVERGENCE EXVA 127 IF(ITER.LT.NITER.OR.ITERM.EQ.1) GO TO 195 EXVA 128 WRITE(MP,2020) NITER EXVA 129 2020 FORMAT(' ** NON CONVERGENCE APRES ',I5,' ITERATIONS') EXVA 130 ITERM=1 EXVA 131 C------- SAUVER LES VALEURS PROPRES EXVA 132 195 DO 200 IS=1,NSS EXVA 133 200 VLAMB(IS)=VLAM1(IS) EXVA 134 C EXVA 135 C------- RESULTAT EXVA 136 C EXVA 137 C------- PLACER DANS L'ORDRE CROISSANT LES VALEURS PROPRES EXVA 138 210 IS1=NSS-1 EXVA 139 DO 230 IS=1,IS1 EXVA 140 I1=IS+1 EXVA 141 C=VLAMB(IS) EXVA 142 II=IS EXVA 143 DO 220 JS=I1,NSS EXVA 144 IF(C.LT.VLAMB(JS)) GO TO 220 EXVA 145 C=VLAMB(JS) EXVA 146 II=JS EXVA 147 220 CONTINUE EXVA 148 VLAMB(II)=VLAMB(IS) EXVA 149 VLAMB(IS)=C EXVA 150 DO 230 ID=1,NEQ EXVA 151 C=VEC(ID,IS) EXVA 152 VEC(ID,IS)=VEC(ID,II) EXVA 153 230 VEC(ID,II)=C EXVA 154 C------- IMPRESSION EXVA 155 WRITE(MP,2030) ITER EXVA 156 2030 FORMAT(/' . . . . CONVERGENCE EN',I4,' ITERATIONS'/) EXVA 157 DO 240 IS=1,NVALP EXVA 158 WRITE(MP,2010) IS,VLAMB(IS) EXVA 159 240 CALL PRSOL(KDLNC,VCORG,VDIMP,KNEQ,VEC(1,IS)) EXVA 160 RETURN EXVA 161 END EXVA 162 SUBROUTINE ASMG(KLD,VDIMP,KLOCE,VCORE,VPRNE,VPREE,KNE,VKE,VFE, ASMG 1 1 VKGS,VKGD,VKGI,VFG,VDLE,VRES) ASMG 2 C=======================================================================ASMG 3 C ASSEMBLAGE DE LA MATRICE MASSE GLOBALE (FONCTION ELEMENTAIRE 5) ASMG 4 C=======================================================================ASMG 5 IMPLICIT REAL*8(A-H,O-Z) ASMG 6 COMMON/ELEM/NELT,NNEL,NTPE,NGRE,ME,NIDENT ASMG 7 COMMON/ASSE/NSYM ASMG 8 COMMON/RESO/NEQ ASMG 9 COMMON/RGDT/IEL,ITPE,ITPE1,IGRE,IDLE,ICE,IPRNE,IPREE,INEL,IDEG,IPGASMG 10 1 ,ICOD ASMG 11 COMMON/ES/M,MR,MP,M1,M2 ASMG 12 DIMENSION KLD(1),VDIMP(1),KLOCE(1),VCORE(1),VPRNE(1),VPREE(1), ASMG 13 1 KNE(1),VKE(1),VFE(1),VKGS(1),VKGD(1),VKGI(1),VFG(1),VDLE(1), ASMG 14 2 VRES(1),KEB(1) ASMG 15 C-----------------------------------------------------------------------ASMG 16 C------- POSITIONNER AU DEBUT LE FICHIER DES ELEMENTS (M2) ASMG 17 REWIND M2 ASMG 18 C------- BOUCLE SUR LES ELEMENTS ASMG 19 DO 30 IE=1,NELT ASMG 20 C------- NE PAS RECALCULER LES ELEMENTS IDENTIQUES ASMG 21 IF(NIDENT.EQ.1.AND.IE.GT.1) GO TO 20 ASMG 22 C------- LIRE UN ELEMENT ASMG 23 CALL RDELEM(M2,KLOCE,VCORE,VPRNE,VPREE,KNE) ASMG 24 C------- CALCUL DES FONCTIONS D'INTERPOLATION SI NECESSAIRE ASMG 25 IF(ITPE.EQ.ITPE1) GO TO 10 ASMG 26 ICOD=2 ASMG 27 CALL ELEMLB(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ASMG 28 C------- CALCUL DE LA MATRICE ELEMENTAIRE ASMG 29 10 ICOD=5 ASMG 30 CALL ELEMLB(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) ASMG 31 C------- IMPRESSION DE LA MATRICE ELEMENTAIRE ASMG 32 IF(M.LT.2) GO TO 20 ASMG 33 IF(NSYM.EQ.0) IKE=IDLE*(IDLE+1)/2 ASMG 34 IF(NSYM.EQ.1) IKE=IDLE*IDLE ASMG 35 WRITE(MP,2000) IEL,(VKE(I),I=1,IKE) ASMG 36 2000 FORMAT(/' MATRICE (ME) , ELEMENT:',I5/(10X,10E12.5)) ASMG 37 C------- ASSEMBLAGE ASMG 38 20 CALL ASSEL(1,0,IDLE,NSYM,KLOCE,KLD,VKE,VFE,VKGS,VKGD,VKGI,VFG) ASMG 39 30 ITPE1=ITPE ASMG 40 RETURN ASMG 41 END ASMG 42 C++++++ FIN FIGURE 6.26 C++++++ DEBUT FIGURE 5.25 SUBROUTINE JACOBI(VK,VM,N,NCYM,EPS,VALP0,VALP,VECT) JACI 1 C=======================================================================JACI 2 C CALCUL DES VALEURS ET VECTEURS PROPRES DE K-LAMBDA.M PAR LA JACI 3 C METHODE GENERALE DE JACOBI. JACI 4 C ENTREES JACI 5 C VK MATRICE K (TRIANGLE SUPERIEUR PAR COLONNES JACI 6 C DESCENDANTES) JACI 7 C VM MATRICE M (TRIANGLE SUPERIEUR PAR COLONNES JACI 8 C DESCENDANTES) JACI 9 C N DIMENSION DES MATRICES K ET M JACI 10 C NCYM NOMBRE DE CYCLES MAXIMUM (15) JACI 11 C EPS PRECISION REQUISE (1.D-12) JACI 12 C TRAVAIL JACI 13 C VALP0 TABLE DE TRAVAIL DE DIMENSION N JACI 14 C SORTIES JACI 15 C VALP VALEURS PROPRES JACI 16 C VECT VECTEURS PROPRES JACI 17 C=======================================================================JACI 18 IMPLICIT REAL*8(A-H,O-Z) JACI 19 COMMON/ES/M,MR,MP JACI 20 DIMENSION VK(1),VM(1),VALP0(N),VALP(N),VECT(N,N) JACI 21 DATA EPSD0/1.D-4/,ZERO/0.D0/,UN/1.D0/,DEUX/2.D0/,QUATR/4.D0/ JACI 22 SQRT(X)=DSQRT(X) JACI 23 ABS(X)=DABS(X) JACI 24 EPS2=EPS*EPS JACI 25 ITR=0 JACI 26 C------- VERIFIER QUE LES TERMES DIAGONAUX SONT POSITIFS, ET JACI 27 C INITIALISER LES VALEURS PROPRES JACI 28 II=0 JACI 29 DO 20 I=1,N JACI 30 II=II+I JACI 31 IF(VK(II).GT.ZERO.AND.VM(II).GT.ZERO) GO TO 10 JACI 32 WRITE(MP,2000) I JACI 33 2000 FORMAT(' ** ERREUR, TERME DIAGONAL NEGATIF DANS JACOBI, LIGNE ', JACI 34 1 I5) JACI 35 STOP JACI 36 10 VALP(I)=VK(II)/VM(II) JACI 37 20 VALP0(I)=VALP(I) JACI 38 C------- INITIALISER LES VECTEURS PROPRES JACI 39 DO 40 I=1,N JACI 40 DO 30 J=1,N JACI 41 30 VECT(I,J)=ZERO JACI 42 40 VECT(I,I)=UN JACI 43 C------- POUR CHAQUE CYCLE JACI 44 DO 250 IC=1,NCYM JACI 45 C------- TOLERANCE DYNAMIQUE JACI 46 EPSD=EPSD0**IC JACI 47 C-------- BALAYAGE DU TRIANGLE SUPERIEUR PAR LIGNES JACI 48 IMAX=N-1 JACI 49 II=0 JACI 50 DO 180 I=1,IMAX JACI 51 I0=II+1 JACI 52 II=II+I JACI 53 IP1=I+1 JACI 54 IJ=II+I JACI 55 JJ=II JACI 56 DO 180 J=IP1,N JACI 57 JP1=J+1 JACI 58 JM1=J-1 JACI 59 J0=JJ+1 JACI 60 JJ=JJ+J JACI 61 J3=JJ-1 JACI 62 C------- CALCUL DES FACTEURS DE COUPLAGE JACI 63 FK=(VK(IJ)*VK(IJ))/(VK(II)*VK(JJ)) JACI 64 FM=(VM(IJ)*VM(IJ))/(VM(II)*VM(JJ)) JACI 65 IF(FK.LT.EPSD.AND.FM.LT.EPSD) GO TO 180 JACI 66 C------- CALCUL DES COEFFICIENTS DE LA TRANSFORMATION JACI 67 ITR=ITR+1 JACI 68 C1=VK(II)*VM(IJ)-VM(II)*VK(IJ) JACI 69 C2=VK(JJ)*VM(IJ)-VM(JJ)*VK(IJ) JACI 70 C3=VK(II)*VM(JJ)-VM(II)*VK(JJ) JACI 71 DET=(C3*C3/QUATR)+(C1*C2) JACI 72 IF(DET.GE.ZERO) GO TO 50 JACI 73 WRITE(MP,2005) I,J JACI 74 2005 FORMAT(' **ERREUR, TRANSFORMATION DE JACOBI SINGULIERE I=',I5, JACI 75 1 ' J=',I5) JACI 76 STOP JACI 77 50 DET=SQRT(DET) JACI 78 D1=C3/DEUX+DET JACI 79 D2=C3/DEUX-DET JACI 80 D=D1 JACI 81 IF(ABS(D2).GT.ABS(D1))D=D2 JACI 82 IF(D.EQ.ZERO) GO TO 60 JACI 83 A=C2/D JACI 84 B=-C1/D JACI 85 GO TO 65 JACI 86 60 A=ZERO JACI 87 B=-VK(IJ)/VK(JJ) JACI 88 C------- MODIFIER LES COLONNES DE K ET M JACI 89 65 IF(I.EQ.1) GO TO 80 JACI 90 IK=I0 JACI 91 J1=IJ-1 JACI 92 DO 70 JK=J0,J1 JACI 93 C1=VK(IK) JACI 94 C2=VK(JK) JACI 95 VK(IK)=C1+B*C2 JACI 96 VK(JK)=C2+A*C1 JACI 97 C1=VM(IK) JACI 98 C2=VM(JK) JACI 99 VM(IK)=C1+B*C2 JACI 100 VM(JK)=C2+A*C1 JACI 101 70 IK=IK+1 JACI 102 80 IF(I.EQ.JM1) GO TO 100 JACI 103 IK=II+I JACI 104 J2=IJ+1 JACI 105 IM=I JACI 106 DO 90 JK=J2,J3 JACI 107 C1=VK(IK) JACI 108 C2=VK(JK) JACI 109 VK(IK)=C1+B*C2 JACI 110 VK(JK)=C2+A*C1 JACI 111 C1=VM(IK) JACI 112 C2=VM(JK) JACI 113 VM(IK)=C1+B*C2 JACI 114 VM(JK)=C2+A*C1 JACI 115 IM=IM+1 JACI 116 90 IK=IK+IM JACI 117 100 IF(J.EQ.N) GO TO 120 JACI 118 IK=IJ+J JACI 119 JK=JJ+J JACI 120 IM=J JACI 121 DO 110 JJK=JP1,N JACI 122 C1=VK(IK) JACI 123 C2=VK(JK) JACI 124 VK(IK)=C1+B*C2 JACI 125 VK(JK)=C2+A*C1 JACI 126 C1=VM(IK) JACI 127 C2=VM(JK) JACI 128 VM(IK)=C1+B*C2 JACI 129 VM(JK)=C2+A*C1 JACI 130 IM=IM+1 JACI 131 IK=IK+IM JACI 132 110 JK=JK+IM JACI 133 120 C1=VK(II) JACI 134 C2=VK(IJ) JACI 135 C3=VK(JJ) JACI 136 B2=B*B JACI 137 BB=DEUX*B JACI 138 A2=A*A JACI 139 AA=DEUX*A JACI 140 VK(II)=C1+BB*C2+B2*C3 JACI 141 VK(IJ)=ZERO JACI 142 VK(JJ)=C3+AA*C2+A2*C1 JACI 143 C1=VM(II) JACI 144 C2=VM(IJ) JACI 145 C3=VM(JJ) JACI 146 VM(II)=C1+BB*C2+B2*C3 JACI 147 VM(IJ)=ZERO JACI 148 VM(JJ)=C3+AA*C2+A2*C1 JACI 149 C------- METTRE A JOUR LES VECTEURS PROPRES JACI 150 DO 170 IJ1=1,N JACI 151 C1=VECT(IJ1,I) JACI 152 C2=VECT(IJ1,J) JACI 153 VECT(IJ1,I)=C1+B*C2 JACI 154 170 VECT(IJ1,J)=C2+A*C1 JACI 155 180 IJ=IJ+J JACI 156 C------- METTRE A JOUR LES VALEURS PROPRES JACI 157 II=0 JACI 158 DO 190 I=1,N JACI 159 II=II+I JACI 160 IF(VK(II).GT.ZERO.AND.VM(II).GT.ZERO) GO TO 190 JACI 161 WRITE(MP,2000) I JACI 162 STOP JACI 163 190 VALP(I)=VK(II)/VM(II) JACI 164 IF(M.GT.1) WRITE(MP,2010)IC,(VALP(I),I=1,N) JACI 165 2010 FORMAT(/' VALEURS PROPRES, CYCLE ',I4/(1X,10E12.5)) JACI 166 C------- TEST DE CONVERGENCE DES VALEURS PROPRES JACI 167 DO 200 I=1,N JACI 168 IF(ABS(VALP(I)-VALP0(I)).GT.(EPS*VALP0(I))) GO TO 230 JACI 169 200 CONTINUE JACI 170 C------- TEST DE CONVERGENCE SUR LES TERMES NON DIAGONAUX JACI 171 JJ=1 JACI 172 DO 210 J=2,N JACI 173 JJ=JJ+J JACI 174 JM1=J-1 JACI 175 II=0 JACI 176 DO 210 I=1,JM1 JACI 177 II=II+I JACI 178 IJ=JJ-J+I JACI 179 FK=VK(IJ)*VK(IJ)/(VK(II)*VK(JJ)) JACI 180 FM=VM(IJ)*VM(IJ)/(VM(II)*VM(JJ)) JACI 181 IF(FK.GT.EPS2.OR.FM.GT.EPS2) GO TO 230 JACI 182 210 CONTINUE JACI 183 C------- NORMALISER LES VECTEURS PROPRES JACI 184 JJ=0 JACI 185 DO 220 J=1,N JACI 186 JJ=JJ+J JACI 187 C1=SQRT(VM(JJ)) JACI 188 DO 220 I=1,N JACI 189 220 VECT(I,J)=VECT(I,J)/C1 JACI 190 C------- CONVERGENCE ATTEINTE JACI 191 IF(M.GT.0) WRITE(MP,2020) IC,ITR JACI 192 2020 FORMAT(15X,'CONVERGENCE EN ',I4,' CYCLES ET ',I5,' TRANSFORMATIONSJACI 193 1 DANS JACOBI') JACI 194 RETURN JACI 195 C------- RECOPIER VALP DANS VALP0 JACI 196 230 DO 240 I=1,N JACI 197 240 VALP0(I)=VALP(I) JACI 198 250 CONTINUE JACI 199 C------- NON CONVERGENCE JACI 200 WRITE(MP,2030) NCYM JACI 201 2030 FORMAT(' ** ERREUR, NON CONVERGENCE DANS JACOBI EN ',I4,' CYCLES')JACI 202 STOP JACI 203 END JACI 204 C++++++ FIN FIGURE 5.25 C++++++ DEBUT FIGURE 4.4 SUBROUTINE ELEM01(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) EL01 1 C=======================================================================EL01 2 C ELEMENT QUADRATIQUE POUR LES PROBLEMES HARMONIQUES ANISOTROPES EL01 3 C A 1,2 OU 3 DIMENSIONS : EL01 4 C 1 DIMENSION: ELEMENT A 3 NOEUDS EL01 5 C 2 DIMENSIONS: ELEMENT ISO-PARAMETRIQUE A 8 NOEUDS EL01 6 C 3 DIMENSIONS: ELEMENT ISO-PARAMETRIQUE A 20 NOEUDS EL01 7 C NOMBRE DE POINTS D'INTEGRATION : 2 DANS CHAQUE DIRECTION EL01 8 C NOMBRE DE DEGRES DE LIBERTE EN CHAQUE NOEUD : 1 EL01 9 C MATRICE OU VECTEUR ELEMENTAIRE CONSTRUIT PAR CE SOUS-PROGRAMME EL01 10 C SELON LA VALEUR DE ICODE : EL01 11 C ICODE.EQ.1 RETOUR DES PARAMETRES EL01 12 C ICODE.EQ.2 CALCUL DES FONCTIONS D'INTERPOLATION ET DES EL01 13 C COEFFICIENTS D'INTEGRATION NUMERIQUE EL01 14 C ICODE.EQ.3 MATRICE ELEMENTAIRE (VKE) EL01 15 C ICODE.EQ.4 MATRICE TANGENTE (VKE)....PAS ECRIT.... EL01 16 C ICODE.EQ.5 MATRICE MASSE (VKE) EL01 17 C ICODE.EQ.6 PRODUIT K . U (VFE) EL01 18 C ICODE.EQ.7 SOLLICITATION ELEMENTAIRE (VFE)....PAS ECRIT.... EL01 19 C ICODE.EQ.8 IMPRESSION DES GRADIENTS EL01 20 C PROPRIETES ELEMENTAIRES EL01 21 C VPREE(1) COEFFICIENT DX EL01 22 C VPREE(2) COEFFICIENT DY EL01 23 C VPREE(3) COEFFICIENT DZ EL01 24 C VPREE(4) CAPACITE SPECIFIQUE DE CHALEUR C EL01 25 C=======================================================================EL01 26 IMPLICIT REAL*8(A-H,O-Z) EL01 27 COMMON/COOR/NDIM EL01 28 COMMON/RGDT/IEL,ITPE,ITPE1,IGRE,IDLE,ICE,IPRNE,IPREE,INEL,IDEG,IPGEL01 29 1 ,ICODE,IDLE0,INEL0,IPG0 EL01 30 COMMON/ES/M,MR,MP EL01 31 DIMENSION VCORE(1),VPRNE(1),VPREE(1),VDLE(1),VKE(1),VFE(1) EL01 32 C....... DIMENSIONS CARACTERISTIQUES DE L'ELEMENT EL01 33 C (VALABLES JUSQU'A 3 DIMENSIONS) EL01 34 C DIMENSION VCPG(IPG),VKPG(NDIM*IPG),XYZ(NDIM) EL01 35 DIMENSION VCPG( 9),VKPG( 27),XYZ( 3) EL01 36 C DIMENSION VJ (NDIM*NDIM),VJ1(NDIM*NDIM) EL01 37 DIMENSION VJ ( 9),VJ1( 9) EL01 38 C DIMENSION VNIX( INEL*NDIM),VNI ((1+NDIM)*INEL*IPG),IPGKED(NDIM) EL01 39 DIMENSION VNIX( 60),VNI ( 2160),IPGKED( 3) EL01 40 C NOMBRE DE P.G. DE SENS KSI,ETA,DZETA EL01 41 DATA IPGKED/3,3,3/ EL01 42 C....... EL01 43 DATA ZERO/0.D0/,EPS/1.D-6/ EL01 44 IKE=IDLE*(IDLE+1)/2 EL01 45 C EL01 46 C------- CHOIX DE LA FONCTION A EXECUTER EL01 47 C EL01 48 GO TO (100,200,300,400,500,600,700,800),ICODE EL01 49 C EL01 50 C------- RETOUR DES PARAMETRES DE L'ELEMENT DANS LE COMMON 'RGDT' EL01 51 C EL01 52 100 GO TO (110,120,130),NDIM EL01 53 110 IDLE0=3 EL01 54 INEL0=3 EL01 55 IPG0=3 EL01 56 RETURN EL01 57 120 IDLE0=8 EL01 58 INEL0=8 EL01 59 IPG0=9 EL01 60 RETURN EL01 61 130 IDLE0=20 EL01 62 INEL0=20 EL01 63 IPG0=27 EL01 64 RETURN EL01 65 C EL01 66 C------- CALCUL DES COORDONNEES ET POIDS DES P.G., EL01 67 C------- DES FONCTIONS N ET DE LEURS DERIVEES EL01 68 C EL01 69 200 CALL GAUSS(IPGKED,NDIM,VKPG,VCPG,IPG) EL01 70 CALL NI01(VKPG,VNI) EL01 71 RETURN EL01 72 C EL01 73 C------- CALCUL DE LA MATRICE RIGIDITE ELEMENTAIRE EL01 74 C EL01 75 C------- INITIALISER VKE EL01 76 300 DO 310 I=1,IKE EL01 77 310 VKE(I)=ZERO EL01 78 C------- BOUCLE SUR LES POINTS D'INTEGRATION EL01 79 INI=1+INEL EL01 80 DO 330 IG=1,IPG EL01 81 C------- CALCUL DU JACOBIEN,DE SON INVERSE ET DE SON DETERMINANT EL01 82 CALL JACOB(VNI(INI),VCORE,NDIM,INEL,VJ,VJ1,DETJ) EL01 83 IF(DETJ.LT.EPS) WRITE(MP,2000) IEL,IG,DETJ EL01 84 2000 FORMAT(' *** ELEM ',I5,' P.G. ',I3,' DET(J)=',E12.5) EL01 85 C------- CALCUL DE DETJ*POIDS EL01 86 COEF=VCPG(IG)*DETJ EL01 87 C------- CALCUL DES FONCTIONS D(NI)/D(X) EL01 88 CALL DNIDX(VNI(INI),VJ1,NDIM,INEL,VNIX) EL01 89 C------- ACCUMULER LES TERMES DE LA MATRICE ELEMENTAIRE EL01 90 IK=0 EL01 91 DO 320 J=1,IDLE EL01 92 DO 320 I=1,J EL01 93 I1=I EL01 94 I2=J EL01 95 C=ZERO EL01 96 DO 315 IJ=1,NDIM EL01 97 C=C+VNIX(I1)*VNIX(I2)*VPREE(IJ) EL01 98 I1=I1+IDLE EL01 99 315 I2=I2+IDLE EL01 100 IK=IK+1 EL01 101 320 VKE(IK)=VKE(IK)+C*COEF EL01 102 C------- PROCHAIN P.G. EL01 103 330 INI=INI+(NDIM+1)*INEL EL01 104 RETURN EL01 105 C EL01 106 C------- CALCUL DE LA MATRICE TANGENTE ELEMENTAIRE EL01 107 C EL01 108 400 CONTINUE EL01 109 RETURN EL01 110 C EL01 111 C------- MATRICE MASSE EL01 112 C EL01 113 500 DO 510 I=1,IKE EL01 114 510 VKE(I)=ZERO EL01 115 IF(VPREE(4).EQ.ZERO)RETURN EL01 116 INI=0 EL01 117 DO 530 IG=1,IPG EL01 118 C------- CALCUL DE LA MATRICE JACOBIENNE EL01 119 I1=INI+INEL+1 EL01 120 CALL JACOB(VNI(I1),VCORE,NDIM,INEL,VJ,VJ1,DETJ) EL01 121 C------- CALCUL DU POIDS EL01 122 COEF=VCPG(IG)*DETJ*VPREE(4) EL01 123 C------- TERMES DE LA MATRICE MASSE EL01 124 IK=0 EL01 125 DO 520 J=1,IDLE EL01 126 DO 520 I=1,J EL01 127 IK=IK+1 EL01 128 I1=INI+I EL01 129 I2=INI+J EL01 130 520 VKE(IK)=VKE(IK)+VNI(I1)*VNI(I2)*COEF EL01 131 530 INI=INI+(NDIM+1)*INEL EL01 132 RETURN EL01 133 C EL01 134 C------- CALCUL DU RESIDU ELEMENTAIRE EL01 135 C EL01 136 600 DO 605 I=1,INEL EL01 137 605 VFE(I)=ZERO EL01 138 INI=1+INEL EL01 139 DO 640 IG=1,IPG EL01 140 C------- CALCUL DE LA MATRICE JACOBIENNE ET DES DERIVEES DE N EN X,Y,Z EL01 141 CALL JACOB(VNI(INI),VCORE,NDIM,INEL,VJ,VJ1,DETJ) EL01 142 CALL DNIDX(VNI(INI),VJ1,NDIM,INEL,VNIX) EL01 143 C------- CALCUL DU COEFFICIENT COMMUN EL01 144 COEF=VCPG(IG)*DETJ EL01 145 C------- PRODUIT VPREE*B*VDLE EL01 146 I1=0 EL01 147 DO 620 I=1,NDIM EL01 148 C=ZERO EL01 149 DO 610 J=1,INEL EL01 150 I1=I1+1 EL01 151 610 C=C+VNIX(I1)*VDLE(J) EL01 152 620 VJ(I)=C*COEF*VPREE(I) EL01 153 C------- PRODUIT (BT)*VJ EL01 154 DO 630 I=1,INEL EL01 155 I1=I-INEL EL01 156 DO 630 J=1,NDIM EL01 157 I1=I1+INEL EL01 158 630 VFE(I)=VFE(I)+VNIX(I1)*VJ(J) EL01 159 640 INI=INI+(NDIM+1)*INEL EL01 160 RETURN EL01 161 C EL01 162 C------- CALCUL DE FE EL01 163 C EL01 164 700 CONTINUE EL01 165 RETURN EL01 166 C EL01 167 C------- CALCUL ET IMPRESSION DES GRADIENTS AUX P.G. EL01 168 C EL01 169 800 WRITE(MP,2010) IEL EL01 170 2010 FORMAT(//' GRADIENTS DANS L ELEMENT :',I4//) EL01 171 IDECL=(NDIM+1)*INEL EL01 172 INI0=1 EL01 173 INI=1+INEL EL01 174 DO 830 IG=1,IPG EL01 175 CALL JACOB(VNI(INI),VCORE,NDIM,INEL,VJ,VJ1,DETJ) EL01 176 CALL DNIDX(VNI(INI),VJ1,NDIM,INEL,VNIX) EL01 177 C------- CALCUL DES COORDONNEES DU P.G. EL01 178 DO 803 I=1,NDIM EL01 179 803 XYZ(I)=ZERO EL01 180 IC=1 EL01 181 I0=INI0 EL01 182 DO 807 IN=1,INEL EL01 183 C=VNI(I0) EL01 184 DO 805 I=1,NDIM EL01 185 XYZ(I)=XYZ(I)+C*VCORE(IC) EL01 186 805 IC=IC+1 EL01 187 807 I0=I0+1 EL01 188 C------- CALCUL DU GRADIENT EL01 189 I1=0 EL01 190 DO 820 I=1,NDIM EL01 191 C=ZERO EL01 192 DO 810 J=1,IDLE EL01 193 I1=I1+1 EL01 194 810 C=C+VNIX(I1)*VDLE(J) EL01 195 820 VJ(I)=C*VPREE(I) EL01 196 C------- IMPRESSION DES GRADIENTS EL01 197 WRITE(MP,2020) IG,(XYZ(I),I=1,NDIM) EL01 198 2020 FORMAT(5X,'P.G. :',I3,' COORDONNEES :',3E12.5) EL01 199 WRITE(MP,2025)(VJ(I),I=1,NDIM) EL01 200 2025 FORMAT(15X,'GRADIENTS :',3E12.5) EL01 201 INI0=INI0+IDECL EL01 202 830 INI=INI+IDECL EL01 203 WRITE(MP,2030) EL01 204 2030 FORMAT(//) EL01 205 RETURN EL01 206 END EL01 207 SUBROUTINE NI01(VKPG,VNI) NI01 1 C=======================================================================NI01 2 C CALCUL DES FONCTIONS D'INTERPOLATION N ET DE LEURS DERIVEES NI01 3 C D(N)/D(KSI) D(N)/D(ETA) PAR LA METHODE GENERALE DE PN INVERSE NI01 4 C POUR DES ELEMENTS QUADRATIQUES A 1 2 OU 3 DIMENSIONS NI01 5 C ENTREES NI01 6 C VKPG COORDONNEES EN LESQUELLES CALCULER N ... NI01 7 C IPG NOMBRE DE POINTS NI01 8 C INEL NOMBRE DE FONCTIONS N (DE NOEUDS) INEL.LE.20 NI01 9 C NDIM NOMBRE DE DIMENSIONS NDIM.LE.3 NI01 10 C SORTIES NI01 11 C VNI FONCTIONS N ET DERIVEES NI01 12 C=======================================================================NI01 13 IMPLICIT REAL*8(A-H,O-Z) NI01 14 COMMON/COOR/NDIM NI01 15 COMMON/RGDT/IEL,ITPE,ITPE1,IGRE,IDLE,ICE,IPRNE,IPREE,INEL,IDEG,IPGNI01 16 COMMON/TRVL/VKSI,VPN,VP,KEXP,KDER,K1 NI01 17 DIMENSION VKPG(1),VNI(1) NI01 18 DIMENSION VKSI1(3),KEXP1(3),VKSI2(16),KEXP2(16),VKSI3(60), NI01 19 1 KEXP3(60) NI01 20 C NI01 21 C....... INFORMATIONS DEFINISSANT LES 3 ELEMENTS DE REFERENCE NI01 22 C (INEL.LE.20 NDIM.LE.3) NI01 23 C DIMENSION VKSI(NDIM*INEL),KEXP(NDIM*INEL),KDER(NDIM) NI01 24 DIMENSION VKSI( 60),KEXP( 60),KDER( 3) NI01 25 C DIMENSION VPN (INEL*INEL),VP(INEL) NI01 26 DIMENSION VPN ( 400),VP( 20) NI01 27 C DIMENSION K1(INEL) NI01 28 DIMENSION K1( 20) NI01 29 C CARACTERISTIQUES DES ELEMENTS DE REFERENCE A 1,2,3 DIM. NI01 30 DATA VKSI1/-1.D0,0.D0,1.D0/,KEXP1/0,1,2/ NI01 31 DATA VKSI2/-1.D0,-1.D0, +0.D0,-1.D0, +1.D0,-1.D0, +1.D0,+0.D0, NI01 32 1 +1.D0,+1.D0, +0.D0,+1.D0, -1.D0,+1.D0, -1.D0,+0.D0/ NI01 33 DATA KEXP2/0,0, 1,0, 0,1, 2,0, 1,1, 0,2, 2,1, 1,2/,IDEGR/2/ NI01 34 DATA VKSI3/-1.D0,-1.D0,-1.D0, +0.D0,-1.D0,-1.D0, NI01 35 1 +1.D0,-1.D0,-1.D0, +1.D0,+0.D0,-1.D0, NI01 36 2 +1.D0,+1.D0,-1.D0, +0.D0,+1.D0,-1.D0, NI01 37 3 -1.D0,+1.D0,-1.D0, -1.D0,+0.D0,-1.D0, NI01 38 4 -1.D0,-1.D0,+0.D0, +1.D0,-1.D0,+0.D0, NI01 39 5 +1.D0,+1.D0,+0.D0, -1.D0,+1.D0,+0.D0, NI01 40 6 -1.D0,-1.D0,+1.D0, +0.D0,-1.D0,+1.D0, NI01 41 7 +1.D0,-1.D0,+1.D0, +1.D0,+0.D0,+1.D0, NI01 42 8 +1.D0,+1.D0,+1.D0, +0.D0,+1.D0,+1.D0, NI01 43 9 -1.D0,+1.D0,+1.D0, -1.D0,+0.D0,+1.D0/ NI01 44 DATA KEXP3/0,0,0, 1,0,0, 0,1,0, 0,0,1, 1,1,1, NI01 45 1 1,1,0, 0,1,1, 1,0,1, 2,0,0, 0,2,0, 0,0,2, NI01 46 2 2,1,0, 2,0,1, 2,1,1, 1,2,0, 0,2,1, 1,2,1, NI01 47 3 1,0,2, 0,1,2, 1,1,2/ NI01 48 C NI01 49 C....... NI01 50 IDEG=IDEGR NI01 51 C------- SELECTIONNER LES TABLES VKSI ET KEXP SELON NDIM NI01 52 I1=NDIM*INEL NI01 53 DO 5 I=1,I1 NI01 54 GO TO (1,2,3),NDIM NI01 55 1 VKSI(I)=VKSI1(I) NI01 56 KEXP(I)=KEXP1(I) NI01 57 GO TO 5 NI01 58 2 VKSI(I)=VKSI2(I) NI01 59 KEXP(I)=KEXP2(I) NI01 60 GO TO 5 NI01 61 3 VKSI(I)=VKSI3(I) NI01 62 KEXP(I)=KEXP3(I) NI01 63 5 CONTINUE NI01 64 C------- CALCUL DE LA MATRICE PN INVERSE NI01 65 CALL PNINV(VKSI,KEXP,VP,K1,VPN) NI01 66 C------- CALCUL DE N,D(N)/D(KSI),D(N)/D(ETA) AUX P.G. NI01 67 I1=1 NI01 68 I2=1 NI01 69 DO 10 IG=1,IPG NI01 70 KDER(1)=0 NI01 71 KDER(2)=0 NI01 72 KDER(3)=0 NI01 73 CALL NI(VKPG(I1),KEXP,KDER,VP,VPN,VNI(I2)) NI01 74 I2=I2+INEL NI01 75 KDER(1)=1 NI01 76 CALL NI(VKPG(I1),KEXP,KDER,VP,VPN,VNI(I2)) NI01 77 I2=I2+INEL NI01 78 IF(NDIM.EQ.1) GO TO 10 NI01 79 KDER(1)=0 NI01 80 KDER(2)=1 NI01 81 CALL NI(VKPG(I1),KEXP,KDER,VP,VPN,VNI(I2)) NI01 82 I2=I2+INEL NI01 83 IF(NDIM.EQ.2) GO TO 10 NI01 84 KDER(2)=0 NI01 85 KDER(3)=1 NI01 86 CALL NI(VKPG(I1),KEXP,KDER,VP,VPN,VNI(I2)) NI01 87 I2=I2+INEL NI01 88 10 I1=I1+NDIM NI01 89 RETURN NI01 90 END NI01 91 C++++++ FIN FIGURE 4.4 C++++++ DEBUT FIGURE 4.5 SUBROUTINE ELEM02(VCORE,VPRNE,VPREE,VDLE,VKE,VFE) EL02 1 C=======================================================================EL02 2 C ELEMENT QUADRATIQUE A 8 NOEUDS POUR L'ELASTICITE A 2 DIMENSIONS EL02 3 C CALCUL DES INFORMATIONS ELEMENTAIRES SELON LA VALEUR DE ICODEEL02 4 C ICODE=1 PARAMETRES DE L'ELEMENT EL02 5 C ICODE=2 FONCTIONS D'INTERPOLATION ET COEFFICIENTS DE GAUSS EL02 6 C ICODE=3 MATRICE RIGIDITE EL02 7 C ICODE=4 MATRICE TANGENTE ... PAS ECRIT ... EL02 8 C ICODE=5 MATRICE MASSE EL02 9 C ICODE=6 RESIDUS EL02 10 C ICODE=7 SECOND MEMBRE EL02 11 C ICODE=8 CALCUL ET IMPRESSION DES CONTRAINTES EL02 12 C PROPRIETES ELEMENTAIRES EL02 13 C VPREE(1) MODULE D'YOUNG EL02 14 C VPREE(2) COEFFICIENT DE POISSON EL02 15 C VPREE(3) .EQ.0 CONTRAINTES PLANES EL02 16 C .EQ.1 DEFORMATIONS PLANES EL02 17 C VPREE(4) MASSE SPECIFIQUE EL02 18 C=======================================================================EL02 19 IMPLICIT REAL*8(A-H,O-Z) EL02 20 COMMON/COOR/NDIM EL02 21 COMMON/ASSE/NSYM EL02 22 COMMON/RGDT/IEL,ITPE,ITPE1,IGRE,IDLE,ICE,IPRNE,IPREE,INEL,IDEG,IPGEL02 23 1 ,ICODE,IDLE0,INEL0,IPG0 EL02 24 COMMON/ES/M,MR,MP EL02 25 DIMENSION VCORE(1),VPRNE(1),VPREE(1),VDLE(1),VKE(1),VFE(1) EL02 26 C....... DIMENSIONS CARACTERISTIQUES DE L'ELEMENT EL02 27 C DIMENSION VCPG( IPG),VKPG(NDIM*IPG),VDE1(IMATD**2) EL02 28 DIMENSION VCPG( 9),VKPG( 18),VDE1( 9) EL02 29 C DIMENSION VBE (IMATD*IDLE),VDE (IMATD**2),VJ (NDIM*NDIM),VJ1(NDIM*EL02 30 DIMENSION VBE ( 48),VDE ( 9),VJ ( 4),VJ1(4) EL02 31 C DIMENSION VNIX( INEL*NDIM),VNI ((1+NDIM)*INEL*IPG),IPGKED(NDIM) EL02 32 DIMENSION VNIX( 16),VNI ( 216),IPGKED( 2) EL02 33 C DIMENSION DE LA MATRICE D,NOMBRE DE P.G. EL02 34 DATA IMATD/3/,IPGKED/3,3/ EL02 35 C....... EL02 36 DATA ZERO/0.D0/,DEUX/2.D0/,X05/0.5D0/,RADN/.572957795130823D2/ EL02 37 DATA EPS/1.D-6/ EL02 38 SQRT(X)=DSQRT(X) EL02 39 ATAN2(X,Y)=DATAN2(X,Y) EL02 40 C EL02 41 C------- CHOIX DE LA FONCTION A EXECUTER EL02 42 C EL02 43 GO TO (100,200,300,400,500,600,700,800),ICODE EL02 44 C EL02 45 C------- RETOUR DES PARAMETRES DE L'ELEMENT DANS COMMON 'RGDT' EL02 46 C EL02 47 100 IDLE0=16 EL02 48 INEL0=8 EL02 49 IPG0=9 EL02 50 C RETURN EL02 51 C EL02 52 C------- CALCUL DES COORDONNEES ET POIDS DE P.G., ET DES FONCTIONS N ETEL02 53 C------- DE LEURS DERIVEES. EL02 54 C EL02 55 200 CALL GAUSS(IPGKED,NDIM,VKPG,VCPG,IPG) EL02 56 IF(M.LT.2) GO TO 220 EL02 57 WRITE(MP,2000) IPG EL02 58 2000 FORMAT(/I5,' POINTS DE GAUSS'/10X,'VCPG',25X,'VKPG') EL02 59 I0=1 EL02 60 DO 210 IG=1,IPG EL02 61 I1=I0+NDIM-1 EL02 62 WRITE(MP,2010) VCPG(IG),(VKPG(I),I=I0,I1) EL02 63 210 I0=I0+NDIM EL02 64 2010 FORMAT(1X,F20.15,5X,3F20.15) EL02 65 220 CALL NI02(VKPG,VNI) EL02 66 IF(M.LT.2) RETURN EL02 67 I1=3*INEL*IPG EL02 68 WRITE(MP,2020) (VNI(I),I=1,I1) EL02 69 2020 FORMAT(/' FONCTIONS N ET DERIVEES'/ (1X,8E12.5)) EL02 70 RETURN EL02 71 C EL02 72 C------- CALCUL DE LA MATRICE RIGIDITE ELEMENTAIRE EL02 73 C EL02 74 C------- INITIALISER VKE EL02 75 300 DO 310 I=1,136 EL02 76 310 VKE(I)=ZERO EL02 77 C------- CALCUL DE D EL02 78 CALL D02(VPREE,VDE) EL02 79 IF(M.GE.2) WRITE(MP,2030) (VDE(I),I=1,9) EL02 80 2030 FORMAT(/' MATRICE D'/1X,9E12.5) EL02 81 C------- BOUCLE SUR LES P.G. EL02 82 I1=1+INEL EL02 83 DO 330 IG=1,IPG EL02 84 C------- CALCUL DU JACOBIEN,DE SON INVERSE ET DE SON DETERMINANT EL02 85 CALL JACOB(VNI(I1),VCORE,NDIM,INEL,VJ,VJ1,DETJ) EL02 86 IF(DETJ.LT.EPS) WRITE(MP,2040) IEL,IG,DETJ EL02 87 2040 FORMAT(' *** ELEM ',I5,' P.G. ',I3,' DET(J)=',E12.5) EL02 88 IF(M.GE.2) WRITE(MP,2050) VJ,VJ1,DETJ EL02 89 2050 FORMAT(/' JACOBIEN=',4E12.5 / ' J INVERS=',4E12.5/' DETJ=',E12.5) EL02 90 C------- CALCUL DE D*COEF EL02 91 C=VCPG(IG)*DETJ EL02 92 DO 320 I=1,9 EL02 93 320 VDE1(I)=VDE(I)*C EL02 94 C------- CALCUL DE B EL02 95 CALL DNIDX(VNI(I1),VJ1,NDIM,INEL,VNIX) EL02 96 IF(M.GE.2) WRITE(MP,2060) (VNIX(I),I=1,16) EL02 97 2060 FORMAT(/' VNIX'/(1X,8E12.5)) EL02 98 CALL B02(VNIX,INEL,VBE) EL02 99 IF(M.GE.2) WRITE(MP,2070) (VBE(I),I=1,48) EL02 100 2070 FORMAT(/' MATRICE B'/(1X,10E12.5)) EL02 101 CALL BTDB(VKE,VBE,VDE1,IDLE,IMATD,NSYM) EL02 102 330 I1=I1+3*INEL EL02 103 RETURN EL02 104 C EL02 105 C------- CALCUL DE LA MATRICE TANGENTE ELEMENTAIRE EL02 106 C EL02 107 400 CONTINUE EL02 108 RETURN EL02 109 C EL02 110 C------- CALCUL DE LA MATRICE MASSE EL02 111 C EL02 112 500 DO 510 I=1,136 EL02 113 510 VKE(I)=ZERO EL02 114 C------- BOUCLE SUR LES P.G. EL02 115 IDIM1=NDIM-1 EL02 116 IDECL=(NDIM+1)*INEL EL02 117 I1=1+INEL EL02 118 I2=0 EL02 119 DO 550 IG=1,IPG EL02 120 CALL JACOB(VNI(I1),VCORE,NDIM,INEL,VJ,VJ1,DETJ) EL02 121 D=VCPG(IG)*DETJ*VPREE(4) EL02 122 C------- ACCUMULER LES TERMES DE MASSE EL02 123 IDL=0 EL02 124 DO 540 J=1,INEL EL02 125 JJ=I2+J EL02 126 J0=1+IDL*(IDL+1)/2 EL02 127 DO 530 I=1,J EL02 128 II=I2+I EL02 129 C=VNI(II)*VNI(JJ)*D EL02 130 VKE(J0)=VKE(J0)+C EL02 131 IF(NDIM.EQ.1) GO TO 530 EL02 132 J1=J0+IDL+2 EL02 133 DO 520 II=1,IDIM1 EL02 134 VKE(J1)=VKE(J1)+C EL02 135 520 J1=J1+J1+1 EL02 136 530 J0=J0+NDIM EL02 137 540 IDL=IDL+NDIM EL02 138 I1=I1+IDECL EL02 139 550 I2=I2+IDECL EL02 140 RETURN EL02 141 C EL02 142 C------- CALCUL DU RESIDU ELEMENTAIRE EL02 143 C EL02 144 C------- CALCUL DE LA MATRICE D EL02 145 600 CALL D02(VPREE,VDE) EL02 146 C------- INITIALISER LE VECTEUR DES RESIDUS EL02 147 DO 610 ID=1,IDLE EL02 148 610 VFE(ID)=ZERO EL02 149 C------- BOUCLE SUR LES P.G. EL02 150 I1=1+INEL EL02 151 DO 640 IG=1,IPG EL02 152 C------- CALCUL DU JACOBIEN EL02 153 CALL JACOB(VNI(I1),VCORE,NDIM,INEL,VJ,VJ1,DETJ) EL02 154 C------- CALCUL DES FONCTIONS D(NI)/D(X) EL02 155 CALL DNIDX(VNI(I1),VJ1,NDIM,INEL,VNIX) EL02 156 C------- CALCUL DES DEFORMATIONS ET CONTRAINTES EL02 157 EPSX=ZERO EL02 158 EPSY=ZERO EL02 159 GAMXY=ZERO EL02 160 ID=1 EL02 161 DO 620 IN=1,INEL EL02 162 UN=VDLE(ID) EL02 163 VN=VDLE(ID+1) EL02 164 C1=VNIX(IN) EL02 165 IN1=IN+INEL EL02 166 C2=VNIX(IN1) EL02 167 EPSX=EPSX+C1*UN EL02 168 EPSY=EPSY+C2*VN EL02 169 GAMXY=GAMXY+C1*VN+C2*UN EL02 170 620 ID=ID+2 EL02 171 C1=VCPG(IG)*DETJ EL02 172 C2=VDE(2)*C1 EL02 173 C3=VDE(9)*C1 EL02 174 C1=VDE(1)*C1 EL02 175 SIGX=C1*EPSX+C2*EPSY EL02 176 SIGY=C2*EPSX+C1*EPSY EL02 177 TAUXY=C3*GAMXY EL02 178 C------- CALCUL DU RESIDU EL02 179 ID=1 EL02 180 DO 630 IN=1,INEL EL02 181 C1=VNIX(IN) EL02 182 IN1=IN+INEL EL02 183 C2=VNIX(IN1) EL02 184 VFE(ID)=VFE(ID)+C1*SIGX+C2*TAUXY EL02 185 VFE(ID+1)=VFE(ID+1)+C2*SIGY+C1*TAUXY EL02 186 630 ID=ID+2 EL02 187 640 I1=I1+3*INEL EL02 188 RETURN EL02 189 C EL02 190 C------- CALCUL DES FORCES DE VOLUME, FX FY PAR UNITE DE VOLUME EL02 191 C ( POUR LA GRAVITE FX=0 FY=-VPREE(4) ) EL02 192 C EL02 193 700 FX=ZERO EL02 194 FY=-VPREE(4) EL02 195 DO 710 I=1,16 EL02 196 710 VFE(I)=ZERO EL02 197 I1=1 EL02 198 IDECL=(NDIM+1)*INEL EL02 199 DO 730 IG=1,IPG EL02 200 CALL JACOB(VNI(I1+INEL),VCORE,NDIM,INEL,VJ,VJ1,DETJ) EL02 201 DX=VCPG(IG)*DETJ EL02 202 DY=DX*FY EL02 203 DX=DX*FX EL02 204 I2=I1 EL02 205 I3=1 EL02 206 DO 720 IN=1,INEL EL02 207 VFE(I3)=VFE(I3)+DX*VNI(I2) EL02 208 VFE(I3+1)=VFE(I3+1)+DY*VNI(I2) EL02 209 I2=I2+1 EL02 210 720 I3=I3+2 EL02 211 730 I1=I1+IDECL EL02 212 RETURN EL02 213 C EL02 214 C------- CALCUL ET IMPRESSION DES CONTRAINTES AUX P.G. EL02 215 C EL02 216 800 WRITE(MP,2080) IEL EL02 217 2080 FORMAT(//' CONTRAINTES DANS L ELEMENT ',I5/ EL02 218 1 ' P.G.',7X,'X',11X,'Y',9X,'EPSX',8X,'EPSY',7X,'GAMXY',8X,'SIGX',EL02 219 2 8X,'SIGY',7X,'TAUXY',8X,'TETA'/ 71X ,'SIG1',8X,'SIG2',7X,'TAUMAX'EL02 220 3 /) EL02 221 C------- CALCUL DE LA MATRICE D EL02 222 CALL D02(VPREE,VDE) EL02 223 C------- BOUCLE SUR LES P.G. EL02 224 I1=1+INEL EL02 225 I2=0 EL02 226 DO 820 IG=1,IPG EL02 227 C------- CALCUL DU JACOBIEN EL02 228 CALL JACOB(VNI(I1),VCORE,NDIM,INEL,VJ,VJ1,DETJ) EL02 229 C------- CALCUL DES FONCTIONS D(NI)/D(X) EL02 230 CALL DNIDX(VNI(I1),VJ1,NDIM,INEL,VNIX) EL02 231 C------- CALCUL DES DEFORMATIONS ET COORDONNEES DU P.G. EL02 232 EPSX=ZERO EL02 233 EPSY=ZERO EL02 234 GAMXY=ZERO EL02 235 X=ZERO EL02 236 Y=ZERO EL02 237 ID=1 EL02 238 DO 810 IN=1,INEL EL02 239 UN=VDLE(ID) EL02 240 VN=VDLE(ID+1) EL02 241 XN=VCORE(ID) EL02 242 YN=VCORE(ID+1) EL02 243 C1=VNIX(IN) EL02 244 IN1=IN+INEL EL02 245 C2=VNIX(IN1) EL02 246 IN1=IN+I2 EL02 247 C3=VNI(IN1) EL02 248 EPSX=EPSX+C1*UN EL02 249 EPSY=EPSY+C2*VN EL02 250 GAMXY=GAMXY+C1*VN+C2*UN EL02 251 X=X+C3*XN EL02 252 Y=Y+C3*YN EL02 253 810 ID=ID+2 EL02 254 C------- CALCUL DES CONTRAINTES EL02 255 SIGX=VDE(1)*EPSX+VDE(2)*EPSY EL02 256 SIGY=VDE(2)*EPSX+VDE(1)*EPSY EL02 257 TAUXY=VDE(9)*GAMXY EL02 258 C------- CALCUL DES CONTRAINTES PRINCIPALES EL02 259 TETA=ATAN2(DEUX*TAUXY,SIGX-SIGY)*X05 EL02 260 TETA=TETA*RADN EL02 261 C1=(SIGX+SIGY)*X05 EL02 262 C2=(SIGX-SIGY)*X05 EL02 263 TAUMAX=SQRT(C2*C2+TAUXY*TAUXY) EL02 264 SIG1=C1+TAUMAX EL02 265 SIG2=C1-TAUMAX EL02 266 WRITE(MP,2090) IG,X,Y,EPSX,EPSY,GAMXY,SIGX,SIGY,TAUXY, EL02 267 1 TETA,SIG1,SIG2,TAUMAX EL02 268 2090 FORMAT(1X,I5,8E12.5,5X,F5.1/66X,3E12.5) EL02 269 I2=I2+3*INEL EL02 270 820 I1=I1+3*INEL EL02 271 RETURN EL02 272 END EL02 273 SUBROUTINE NI02(VKPG,VNI) NI02 1 C=======================================================================NI02 2 C CALCUL DES FONCTIONS D'INTERPOLATION N ET DE LEURS DERIVEES NI02 3 C D(N)/D(KSI) ET D(N)/D(ETA) PAR LA METHODE GENERALE DE PN INVERSE NI02 4 C ENTREES NI02 5 C VKPG COORDONNEES EN LESQUELLES CALCULER N ... NI02 6 C IPG NOMBRE DE POINTS NI02 7 C INEL NOMBRE DE FONCTIONS N (DE NOEUDS) INEL.EQ.8 NI02 8 C NDIM NOMBRE DE DIMENSIONS NDIM.EQ.2 NI02 9 C SORTIE NI02 10 C VNI FONCTIONS N ET DERIVEES NI02 11 C=======================================================================NI02 12 IMPLICIT REAL*8(A-H,O-Z) NI02 13 COMMON/COOR/NDIM NI02 14 COMMON/RGDT/IEL,ITPE,ITPE1,IGRE,IDLE,ICE,IPRNE,IPREE,INEL,IDEG,IPGNI02 15 DIMENSION VKPG(1),VNI(1) NI02 16 C NI02 17 C....... INFORMATIONS LIEES A L'ELEMENT DE REFERENCE CARRE A 8 NOEUDS NI02 18 C (INEL.EQ.8 NDIM.EQ.2) NI02 19 C DIMENSION VKSI(NDIM*INEL),KEXP(NDIM*INEL),KDER(NDIM) NI02 20 DIMENSION VKSI( 16),KEXP( 16),KDER( 2) NI02 21 C DIMENSION VPN (INEL*INEL),VP(INEL),K1(INEL) NI02 22 DIMENSION VPN ( 64),VP( 8),K1( 8) NI02 23 C COORDONNEES DES NOEUDS DE L'ELEMENT DE REFERENCE NI02 24 DATA VKSI/-1.D0,-1.D0, +0.D0,-1.D0, +1.D0,-1.D0, +1.D0,+0.D0, NI02 25 1 +1.D0,+1.D0, +0.D0,+1.D0, -1.D0,+1.D0, -1.D0,+0.D0/ NI02 26 C EXPOSANTS DES MONOMES DE LA BASE POLYNOMIALE,DEGRE MAX. NI02 27 DATA KEXP/0,0, 1,0, 0,1, 2,0, 1,1, 0,2, 2,1, 1,2/,IDEGR/2/ NI02 28 C NI02 29 C....... NI02 30 IDEG=IDEGR NI02 31 C------- CALCUL DE LA MATRICE PN INVERSE NI02 32 CALL PNINV(VKSI,KEXP,VP,K1,VPN) NI02 33 C------- CALCUL DE N,D(N)/D(KSI),D(N)/D(ETA) AUX P.G. NI02 34 I1=1 NI02 35 I2=1 NI02 36 DO 10 IG=1,IPG NI02 37 KDER(1)=0 NI02 38 KDER(2)=0 NI02 39 CALL NI(VKPG(I1),KEXP,KDER,VP,VPN,VNI(I2)) NI02 40 I2=I2+INEL NI02 41 KDER(1)=1 NI02 42 CALL NI(VKPG(I1),KEXP,KDER,VP,VPN,VNI(I2)) NI02 43 I2=I2+INEL NI02 44 KDER(1)=0 NI02 45 KDER(2)=1 NI02 46 CALL NI(VKPG(I1),KEXP,KDER,VP,VPN,VNI(I2)) NI02 47 I2=I2+INEL NI02 48 10 I1=I1+NDIM NI02 49 RETURN NI02 50 END NI02 51 SUBROUTINE D02(VPREE,VDE) D02 1 C=======================================================================D02 2 C CONSTRUCTION DE LA MATRICE D (ELASTICITE A 2 DIMENSIONS) D02 3 C ENTREES D02 4 C VPREE PROPRIETES ELEMENTAIRES D02 5 C VPREE(1) MODULE D'YOUNG D02 6 C VPREE(2) COEFFICIENT DE POISSON D02 7 C VPREE(3) .EQ.0 CONTRAINTES PLANES D02 8 C .EQ.1 DEFORMATIONS PLANES D02 9 C SORTIES D02 10 C VDE MATRICE D (PLEINE) D02 11 C=======================================================================D02 12 IMPLICIT REAL*8(A-H,O-Z) D02 13 DIMENSION VPREE(1),VDE(9) D02 14 DATA ZERO/0.D0/,UN/1.D0/,DEUX/2.D0/ D02 15 E=VPREE(1) D02 16 X=VPREE(2) D02 17 A=VPREE(3) D02 18 C1=E*(UN-A*X)/((UN+X)*(UN-X-A*X)) D02 19 C2=C1*X/(UN-A*X) D02 20 C3=E/(DEUX*(UN+X)) D02 21 VDE(1)=C1 D02 22 VDE(2)=C2 D02 23 VDE(3)=ZERO D02 24 VDE(4)=C2 D02 25 VDE(5)=C1 D02 26 VDE(6)=ZERO D02 27 VDE(7)=ZERO D02 28 VDE(8)=ZERO D02 29 VDE(9)=C3 D02 30 RETURN D02 31 END D02 32 SUBROUTINE B02(VNIX,INEL,VBE) B02 1 C=======================================================================B02 2 C CONSTRUCTION DE LA MATRICE B (ELASTICITE A 2 DIMENSIONS) B02 3 C ENTREES B02 4 C VNIX DERIVEES DES FONCTIONS D'INTERPOLATION EN X,Y,Z B02 5 C INEL NOMBRE DE FONCTIONS D'INTERPOLATION B02 6 C SORTIE B02 7 C VBE MATRICE B B02 8 C=======================================================================B02 9 IMPLICIT REAL*8(A-H,O-Z) B02 10 DIMENSION VNIX(INEL,1),VBE(3,1) B02 11 DATA ZERO/0.D0/ B02 12 J=1 B02 13 DO 10 I=1,INEL B02 14 C1=VNIX(I,1) B02 15 C2=VNIX(I,2) B02 16 VBE(1,J)=C1 B02 17 VBE(1,J+1)=ZERO B02 18 VBE(2,J)=ZERO B02 19 VBE(2,J+1)=C2 B02 20 VBE(3,J)=C2 B02 21 VBE(3,J+1)=C1 B02 22 10 J=J+2 B02 23 RETURN B02 24 END B02 25 SUBROUTINE BTDB(VKE,VBE,VDE,IDLE,IMATD,NSYM) BTDB 1 C=======================================================================BTDB 2 C AJOUTE LE PRODUIT B(T).D.B A VKE BTDB 3 C ENTREES BTDB 4 C VKE MATRICE ELEMENTAIRE NON SYMETRIQUE (NSYM.EQ.1) BTDB 5 C SYMETRIQUE (NSYM.EQ.0) BTDB 6 C VBE MATRICE B BTDB 7 C VDE MATRICE D (PLEINE) BTDB 8 C IDLE NOMBRE TOTAL DE D.L. DE L'ELEMENT BTDB 9 C IMATD DIMENSION DE LA MATRICE D (MAX. 6) BTDB 10 C SORTIE BTDB 11 C VKE BTDB 12 C=======================================================================BTDB 13 IMPLICIT REAL*8(A-H,O-Z) BTDB 14 DIMENSION VKE(1),VBE(IMATD,1),VDE(IMATD,1),T(6) BTDB 15 DATA ZERO/0.D0/ BTDB 16 C-----------------------------------------------------------------------BTDB 17 IJ=1 BTDB 18 IMAX=IDLE BTDB 19 DO 40 J=1,IDLE BTDB 20 DO 20 I1=1,IMATD BTDB 21 C=ZERO BTDB 22 DO 10 J1=1,IMATD BTDB 23 10 C=C+VDE(I1,J1)*VBE(J1,J) BTDB 24 20 T(I1)=C BTDB 25 IF(NSYM.EQ.0) IMAX=J BTDB 26 DO 40 I=1,IMAX BTDB 27 C=ZERO BTDB 28 DO 30 J1=1,IMATD BTDB 29 30 C=C+VBE(J1,I)*T(J1) BTDB 30 VKE(IJ)=VKE(IJ)+C BTDB 31 40 IJ=IJ+1 BTDB 32 RETURN BTDB 33 END BTDB 34 C++++++ FIN FIGURE 4.5 SUBROUTINE ELEM03 ENTRY ELEM04 RETURN ENTRY ELEM05 RETURN ENTRY ELEM06 RETURN ENTRY ELEM07 RETURN ENTRY ELEM08 RETURN ENTRY ELEM09 RETURN ENTRY ELEM10 RETURN END