1!
2!     CalculiX - A 3-dimensional finite element program
3!     Copyright (C) 1998-2021 Guido Dhondt
4!
5!     This program is free software; you can redistribute it and/or
6!     modify it under the terms of the GNU General Public License as
7!     published by the Free Software Foundation(version 2);
8!
9!
10!     This program is distributed in the hope that it will be useful,
11!     but WITHOUT ANY WARRANTY; without even the implied warranty of
12!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13!     GNU General Public License for more details.
14!
15!     You should have received a copy of the GNU General Public License
16!     along with this program; if not, write to the Free Software
17!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
18!
19      subroutine writetrilinos(jq,irow,ad,au,b,neq,nzs,symmetryflag,
20     &     inputformat,co,nk,nactdof,jobnamef,mi)
21!
22      implicit none
23!
24      character*132 jobnamef,fnlhs,fnrhs,fnrig
25!
26      integer jq(*),irow(*),neq,nzs,symmetryflag,inputformat,nk,
27     &     mi(*),nactdof(0:mi(2),*),iperm(3*nk),i,j,k
28!
29      real*8 ad(*),au(*),b(*),co(3,*),null,one
30!
31      fnlhs=jobnamef(1:index(jobnamef,' ')-1)//'.lhs'
32      fnrhs=jobnamef(1:index(jobnamef,' ')-1)//'.rhs'
33      fnrig=jobnamef(1:index(jobnamef,' ')-1)//'.rig'
34!
35      null=0.d0
36      one=1.d0
37!
38      open(50,file=fnlhs,status='unknown')
39!
40!     left hand side: fill-in equations
41!
42      k=0
43      do i=1,nk
44        if((nactdof(1,i).le.0).and.(nactdof(2,i).le.0).and.
45     &       (nactdof(3,i).le.0)) cycle
46        do j=1,3
47          k=k+1
48          if(nactdof(j,i).gt.0) then
49            iperm(nactdof(j,i))=k
50          else
51            write(50,*) k,k,one
52          endif
53        enddo
54      enddo
55!
56!     left hand side: significant contributions
57!
58      if(symmetryflag.eq.0) then
59!
60!       symmetric
61!
62        do i=1,neq
63          write(50,*) iperm(i),iperm(i),ad(i)
64        enddo
65        do i=1,neq
66          do j=jq(i),jq(i+1)-1
67            write(50,*) iperm(irow(j)),iperm(i),au(j)
68            write(50,*) iperm(i),iperm(irow(j)),au(j)
69          enddo
70        enddo
71      elseif(inputformat.eq.1) then
72!
73!        not symmetric
74!
75        do i=1,neq
76          write(50,*) iperm(i),iperm(i),ad(i)
77        enddo
78        do i=1,neq
79          do j=jq(i),jq(i+1)-1
80            write(50,*) iperm(irow(j)),iperm(i),au(j)
81            write(50,*) iperm(i),iperm(irow(j)),au(j+nzs)
82          enddo
83        enddo
84      else
85        write(*,*) '*ERROR in writetrilinos: input format'
86        write(*,*) '       not known'
87        call exit(201)
88      endif
89      close(50)
90!
91!     right hand side
92!
93      open(50,file=fnrhs,status='unknown')
94      do i=1,neq
95        write(50,*) iperm(i),b(i)
96      enddo
97      close(50)
98!
99!     rigid body modes
100!
101      open(50,file=fnrig,status='unknown')
102      do i=1,nk
103        if((nactdof(1,i).le.0).and.(nactdof(2,i).le.0).and.
104     &       (nactdof(3,i).le.0)) cycle
105        write(50,*) one,null,null,null,co(3,i),-co(2,i)
106        write(50,*) null,one,null,-co(3,i),null,co(1,i)
107        write(50,*) null,null,one,co(2,i),-co(1,i),null
108      enddo
109      close(50)
110!
111      stop
112      end
113
114