C WRMTAK SOURCE CHAT 05/01/13 04:12:25 5004 SUBROUTINE WRMTAK(IFSAU,ITLACC,IMAX1,IFORM,IDEB) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) C*********************************************************************** C NOM : WRMTAK C DESCRIPTION : Ecriture des objets de type MATRAK sur le C fichier IFSAU C (appelé par wrpil.eso) C C LANGAGE : ESOPE C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/TTMF) C mél : gounand@semt2.smts.cea.fr C*********************************************************************** C APPELES (E/S) : ECDIFE (ecriture d'un tableau d'entiers) C ECDIFR (ecriture d'un tableau de REAL*8) C*********************************************************************** C SYNTAXE GIBIANE : SAUV C ENTREES : IFSAU, numéro du fichier en écriture C IDEB, IMAX1, indice de début et de fin C de la pile des objets MATRAK (ITLACC) C à écrire. C IFORM, le fichier a ecrire est formaté ou C non. C*********************************************************************** C VERSION : v1, 15/07/98, version initiale C HISTORIQUE : v1, 15/07/98, création C HISTORIQUE : C HISTORIQUE : C*********************************************************************** C Prière de PRENDRE LE TEMPS de compléter les commentaires C en cas de modification de ce sous-programme afin de faciliter C la maintenance ! C*********************************************************************** -INC CCOPTIO C-INC SMMATRAKANC C************************************************************************* C C REPERAGE ET STOKAGE DES MATRICES ELEMENTAIRES puis assemblees C * LGEOC SPG de la pression et/ou des multiplicateurs de Lagrange * (points CENTRE ) pour chaque operateur de contrainte * KGEOC SPG pour la totalite des points CENTRE. * KGEOS SPG pour la totalite des points SOMMET (Diagonale vitesse) * KLEMC Connectivites de l'ensemble des contraintes * LIZAFM(NBSOUS) contient les pointeurs IZAFM des sous-zones SEGMENT MATRAK INTEGER LGEOC(NBOP),IDEBS(NBOP),IFINS(NBOP) INTEGER LIZAFM(NBSOUS) INTEGER IKAM0 (NBSOUS) INTEGER IMEM (NBELC) INTEGER KLEMC,KGEOS,KGEOC,KDIAG,KCAC,KIZCL,KIZGC ENDSEGMENT SEGMENT IZAFM REAL*8 AM(NNELP,NP,IESP),RPGI(NELAX) ENDSEGMENT C************************************************************************* -INC SMMATRK1 -INC TMCOLAC SEGMENT IZA REAL*8 A(NBVA) ENDSEGMENT C INTEGER NDTAB INTEGER IEL,I INTEGER ILENA(7) C====================================================================== * * Executable statements * C C ... BOUCLE SUR LES MATRAK DE LA PILE DO 1 IEL=IDEB,IMAX1 MATRAK=ITLAC(IEL) IF (MATRAK.EQ.0) THEN WRITE(IOIMP,*) 'Failing to save a nil pointer' WRITE(IOIMP,*) 'MATRAK type object...' GOTO 9999 ENDIF C Sauvegarde du chapeau C Dimensions SEGACT MATRAK NBOP =LGEOC(/1) NBSOUS=LIZAFM(/1) NBELC =IMEM(/1) ILENA(1)=NBOP ILENA(2)=NBSOUS ILENA(3)=NBELC NDTAB=3 CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) C Rigidités élémentaires NDTAB=NBOP CALL ECDIFE(IFSAU,NDTAB,LGEOC,IFORM) NDTAB=NBOP CALL ECDIFE(IFSAU,NDTAB,IDEBS,IFORM) NDTAB=NBOP CALL ECDIFE(IFSAU,NDTAB,IFINS,IFORM) NDTAB=NBSOUS CALL ECDIFE(IFSAU,NDTAB,LIZAFM,IFORM) NDTAB=NBSOUS CALL ECDIFE(IFSAU,NDTAB,IKAM0,IFORM) NDTAB=NBELC CALL ECDIFE(IFSAU,NDTAB,IMEM,IFORM) ILENA( 1)=KLEMC ILENA( 2)=KGEOS ILENA( 3)=KGEOC ILENA( 4)=KDIAG ILENA( 5)=KCAC ILENA( 6)=KIZCL ILENA( 7)=KIZGC NDTAB=7 CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) C Sauvegarde des IZAFM DO 11 I=1,NBSOUS IZAFM=LIZAFM(I) IF (IZAFM.NE.0) THEN SEGACT IZAFM NNELP=AM(/1) NP =AM(/2) IESP =AM(/3) NELAX=RPGI(/1) ILENA(1)=NNELP ILENA(2)=NP ILENA(3)=IESP ILENA(4)=NELAX NDTAB=4 CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) NDTAB=NNELP*NP*IESP CALL ECDIFR(IFSAU,NDTAB,AM,IFORM) NDTAB=NELAX CALL ECDIFR(IFSAU,NDTAB,RPGI,IFORM) SEGDES IZAFM ENDIF 11 CONTINUE C Sauvegarde du IZL IF (KIZCL.NE.0) THEN IZL=KIZCL SEGACT IZL C Dimensions NJA=KZA(/1) NJAN=NUAN(/1) NJAB=B(/1) ILENA(1)=NJA ILENA(2)=NJAN ILENA(3)=NJAB ILENA(4)=KZA1 NDTAB=4 CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) C Contenu des tableaux NDTAB=NJA CALL ECDIFE(IFSAU,NDTAB,KZA,IFORM) NDTAB=NJAN CALL ECDIFE(IFSAU,NDTAB,NUAN,IFORM) NDTAB=NJAN CALL ECDIFE(IFSAU,NDTAB,NUNA,IFORM) NDTAB=NJAN CALL ECDIFE(IFSAU,NDTAB,IMEL,IFORM) NDTAB=NJAN CALL ECDIFE(IFSAU,NDTAB,IMJ,IFORM) NDTAB=NJAB CALL ECDIFR(IFSAU,NDTAB,B,IFORM) C Sauvegarde du IDMAT IF (KZA1.NE.0) THEN IDMAT=KZA1 SEGACT IDMAT C Dimension NBLK=IDESCR(/1) ILENA(1)=NBLK ILENA(2)=IDIAG NDTAB=2 CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) NDTAB=NBLK CALL ECDIFE(IFSAU,NDTAB,IDESCR,IFORM) NDTAB=NBLK+1 CALL ECDIFE(IFSAU,NDTAB,NLDBLK,IFORM) IF (IDIAG.NE.0) THEN IZA=IDIAG SEGACT IZA NBVA=A(/1) ILENA(1)=NBVA NDTAB=1 CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) NDTAB=NBVA CALL ECDIFR(IFSAU,NDTAB,A,IFORM) SEGDES IZA ENDIF C Sauvegarde des IDBLK DO 211 INBLK=1,NBLK IDBLK=IDESCR(INBLK) IF (IDBLK.NE.0) THEN SEGACT IDBLK C Dimension NLBLK=IDEBLK(/1)-1 ILENA(1)=NLBLK ILENA(2)=IMAT ILENA(3)=ILON NDTAB=3 CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) NDTAB=NLBLK+1 CALL ECDIFE(IFSAU,NDTAB,IDEBLK,IFORM) IF (IMAT.NE.0) THEN IZA=IMAT SEGACT IZA NBVA=A(/1) ILENA(1)=NBVA NDTAB=1 CALL ECDIFE(IFSAU,NDTAB,ILENA,IFORM) NDTAB=NBVA CALL ECDIFR(IFSAU,NDTAB,A,IFORM) SEGDES IZA ENDIF SEGDES IDBLK ENDIF 211 CONTINUE SEGDES IDMAT ENDIF SEGDES IZL ENDIF SEGDES MATRAK 1 CONTINUE * * Normal termination * RETURN * * Format handling * * * Error handling * 9999 CONTINUE WRITE(IOIMP,*) 'An error was detected in subroutine wrmtak' RETURN * * End of subroutine WRMTIK * END