c$Id:$ subroutine umacr3(lct,ctl,prt) c * * F E A P * * A Finite Element Analysis Program c.... Copyright (c) 1984-2009: Regents of the University of California c All rights reserved c-----[--.----+----.----+----.-----------------------------------------] c Purpose: Output of arrays for use with Matlab sparse options. c Use: c Example: Output of residual c form c output dr c Example: Output of tangent c tang,,-1 c output tang c Creates files with name 'dr' and 'tang'. c Format: i j a(i,j) c Matlab use: c load dr c b = sparse(dr(:,1),dr(:,2),dr(:,3)) c load tang c a = sparse(tang(:,1),tang(:,2),tang(:,3)) c Inputs: c lct - Command character parameters c ctl(3) - Command numerical parameters c prt - Flag, output if true c Outputs: c To files with array name c-----[--.----+----.----+----.-----------------------------------------] implicit none include 'cdata.h' include 'compas.h' include 'iodata.h' include 'iofile.h' include 'part0.h' include 'umac1.h' include 'pointer.h' include 'comblk.h' logical pcomp,prt character lct*15,array*4 real*8 ctl(3) integer i save c Set command word if(pcomp(uct,'mac3',4)) then ! Usual form uct = 'outp' ! Specify name as 'outp'ut elseif(urest.eq.1) then ! Read restart data elseif(urest.eq.2) then ! Write restart data c Perform array outputs in Matlab sparse format else ! Perform user operation c Get array name array = lct(1:4) open(unit = ios,file = array,status = 'unknown') rewind(ios) c Tangent terms if(pcomp(array,'tang',4)) then if(ittyp.eq.-1 .or. ittyp.eq.-2) then ! Blocked or Sparse if(max(abs(np(93)),abs(np(94)),abs(np(npart))).eq.0) then go to 400 else call ustang(neq,mr(np(93)),mr(np(94)),hr(np(npart))) endif elseif(ittyp.eq.-3) then ! Profile if(max(abs(np(20+npart)),abs(np(npart))).eq.0) then go to 400 else call uptang(neq,mr(np(20+npart)),hr(np(npart)), & hr(np(npart)+neq)) endif endif elseif(pcomp(array,'utan',4)) then if(ittyp.eq.-3) then ! Profile if(max(abs(np(20+npart)),abs(np(npart)), & abs(np(npart+4))).eq.0) then go to 400 else call uptang(neq,mr(np(20+npart)),hr(np(npart)), & hr(np(npart+4))) endif endif c Mass terms elseif(pcomp(array,'lmas',4)) then if(abs(np(npart+12)).eq.0) then go to 400 else call ulmass(neq,hr(np(npart+12))) endif elseif(pcomp(array,'mass',4) .or. pcomp(array,'cmas',4)) then if(max(abs(np(90)),abs(np(91)),abs(np(npart+8))).eq.0) then go to 400 else call usmass(neq,mr(np(90)),mr(np(91)),hr(np(npart+8)),2) endif elseif(pcomp(array,'umas',4)) then if(max(abs(np(90)),abs(np(91)),abs(np(npart+8))).eq.0) then go to 400 else call usmass(neq,mr(np(90)),mr(np(91)),hr(np(npart+8)),3) endif c Damping terms elseif(pcomp(array,'damp',4) .or. pcomp(array,'cdam',4)) then if(max(abs(np(203)),abs(np(204)),abs(np(npart+16))).eq.0) then go to 400 else call usmass(neq,mr(np(203)),mr(np(204)),hr(np(npart+16)),2) endif elseif(pcomp(array,'udam',4)) then if(max(abs(np(203)),abs(np(204)),abs(np(npart+16))).eq.0) then go to 400 else call usmass(neq,mr(np(203)),mr(np(204)),hr(np(npart+16)),3) endif c Residual terms elseif(pcomp(array,'dr ',2) .or. pcomp(array,'form',4)) then if(abs(np(26)).eq.0) then go to 400 else call urform(neq,hr(np(26))) endif endif close(unit = ios, status = 'keep') endif return c Error 400 write(iow,4000) array write(ilg,4000) array if(ior.lt.0) then write(*,4000) array endif close(unit = ios, status = 'delete') c format 4000 format(' *ERROR* Array ',a,' can not be output -- missing data'/) end subroutine uptang(neq,jp,ad, al) c-----[--+---------+---------+---------+---------+---------+---------+-] c Purpose: Output of profile stored tangent c Inputs: c neq - Number of equations c jp(*) - Column pointers c ad(*) - Diagonal and upper part of array c al(*) - Lower part of array c-----[--+---------+---------+---------+---------+---------+---------+-] implicit none include 'iodata.h' integer ii,i,j, neq,jp(*) real*8 ad(*), al(*) c Output diagonal entries do i = 1,neq if(ad(i).ne.0.0d0) then write(ios,2001) i,i, ad(i) endif end do ! i c Output last entry if zero (helps Matlab size array) if(ad(neq).eq.0.0d0) then write(ios,2001) neq, neq, ad(neq) endif c Output off-diagonal entries do j = 2,neq ii = j - jp(j) + jp(j-1) do i = jp(j-1)+1,jp(j) if(ad(neq+i).ne.0.0d0) then write(ios,2001) ii,j,ad(neq+i) endif if(al(i).ne.0.0d0) then write(ios,2001) j,ii,al(i) endif ii = ii + 1 end do ! i end do ! j c format 2001 format(2i10,1p,1d25.15) end subroutine ustang(neq,ir,jc,ad) c-----[--+---------+---------+---------+---------+---------+---------+-] c Purpose: Output of symmetric sparse stored tangent c Inputs: c neq - Number of equations c ir(*) - Row pointers c jc(*) - Entries in each row c ad(*) - Diagonal and upper part of array c-----[--+---------+---------+---------+---------+---------+---------+-] implicit none include 'iodata.h' integer i1,ii,i,j, neq,ir(*),jc(*) real*8 ad(*) i1 = 1 do i = 1,neq do j = i1,ir(i) if(ad(j).ne.0.0d0) then write(ios,2001) i,jc(j),ad(j) if(i.ne.jc(j)) then write(ios,2001) jc(j),i,ad(j) endif endif end do ! j i1 = ir(i) + 1 end do ! i c format 2001 format(2i10,1p,1d25.15) end subroutine ulmass(neq,ad) c-----[--+---------+---------+---------+---------+---------+---------+-] c Purpose: Output of diagonal (lumped) mass c Inputs: c neq - Number of equations c ad(*) - Diagonal entries of mass c-----[--+---------+---------+---------+---------+---------+---------+-] implicit none include 'iodata.h' integer i, neq real*8 ad(*) do i = 1,neq if(ad(i).ne.0.0d0) then write(ios,2001) i,i,ad(i) endif end do ! i c Output last entry if zero (helps Matlab size array) if(ad(neq).eq.0.0d0) then write(ios,2001) neq, neq, ad(neq) endif c format 2001 format(2i10,1p,1d25.15) end subroutine usmass(neq,ir,jc,ad,isw) c-----[--+---------+---------+---------+---------+---------+---------+-] c Purpose: Output of consistent mass/damping array (sparse) c Inputs: c neq - Number of equations c ir(*) - Row pointers c jc(*) - Entries in each row c ad(*) - Diagonal and upper part of array c isw - Switch: 1 = diagonal; 2 = symmetric; 3 = unsymmetric c-----[--+---------+---------+---------+---------+---------+---------+-] implicit none include 'iodata.h' integer isw,i1,ii,i,j, neq,ir(*),jc(*) real*8 ad(*) c Output diagonal entries do i = 1,neq if(ad(i).ne.0.0d0) then write(ios,2001) i,i,ad(i) endif end do ! i c Output the last element if it is zero (for Matlab dimensioning) if(ad(neq).eq.0.0d0) then write(ios,2001) neq,neq,ad(neq) endif c Output off-diagonal entries if(isw.ge.2) then i1 = 1 do i = 1,neq do j = i1,ir(i) if(ad(j+neq).ne.0.0d0) then write(ios,2001) jc(j),i,ad(j+neq) if(isw.eq.2) then write(ios,2001) i,jc(j),ad(j+neq) endif endif if(isw.eq.3 .and. ad(j+neq+ir(neq)).ne.0.0d0) then if(i.ne.jc(j)) then write(ios,2001) i,jc(j),ad(j+neq+ir(neq)) endif endif end do ! j i1 = ir(i) + 1 end do ! i endif c format 2001 format(2i10,1p,1d25.15) end subroutine urform(neq,dr) c-----[--+---------+---------+---------+---------+---------+---------+-] c Purpose: Output of residual vector c Inputs: c neq - Number of equations c dr(*) - Vector entries c-----[--+---------+---------+---------+---------+---------+---------+-] implicit none include 'iodata.h' integer i,neq real*8 dr(*) do i = 1,neq if(dr(i).ne.0.0d0) then write(ios,2001) i, 1, dr(i) endif end do ! c Output last entry if zero (helps Matlab size array) if(dr(neq).eq.0.0d0) then write(ios,2001) neq, 1, dr(neq) endif c format 2001 format(2i10,1p,1d25.15) end