NLSL: convtc.f90 Source File

NLSL

- Main Page
- Modules
- Data Types List
- Files

- File List
- File Members

convtc.f90
Go to the documentation of this file.
1 c Version 1.4 10/10/94
2 c----------------------------------------------------------------------
3 c ====================
4 c subroutine CONVTC
5 c ====================
6 c
7 c Subroutine to convert the tensor named on the passed command line
8 c according to the symmetry specified by iflg. The following are
9 c valid symmetries:
10 c 1: Cartesian
11 c 2: Spherical
12 c 3: Axial
13 c See source file tensym.f for an explanation of these symmetries.
14 c
15 c Uses:
16 c gettkn, touppr (in strutl.f)
17 c ipfind.f
18 c itrim.f
19 c indtkn.f
20 c rmvprm.f
21 c tocart, tosphr, toaxil (in tensym.f)
22 c
23 c----------------------------------------------------------------------
24 c
25 subroutine convtc( line, iflg )
26 c
27 use nlsdim
28 use eprprm
29 use parcom
30 use stdio
31 use lpnam
32 use symdef
33 c
34 implicit none
35 c
36 character line*80, token*30, ident*9, varstr*9, tnstr*9
37 integer i,iflg,ix,ixa,ixf,ixten,ix2,j,jx,jx1,jx2,lth,k
38 c
39 integer ipfind,indtkn,itrim
40 external ipfind,indtkn,itrim
41 c
42 c######################################################################
43 c
44 if (iflg.lt.cartesian .or. iflg.gt.axial) then
45 write (luttyo,1006)
46 return
47 end if
48 c
49 call gettkn(line,token,lth)
50 call touppr(token,lth)
51 c
52 c *** No tensor specified
53 if (lth.eq.0) then
54
55 write (luout,1000)
56 return
57 end if
58 c
59 lth=1
60 ix=ipfind(token,lth)
61 ixa=abs(mod(ix,100))
62 if (ix.gt.100) ixa=0
63 c
64 ix2=indtkn(line)
65 if (ix2.le.0) then
66 jx1=1
67 jx2=mxsite
68 else
69 jx1=ix2
70 jx2=ix2
71 end if
72 c
73 if (ixa.eq.0 .or. ixa-iwxx.ge.nalias) then
74 c
75 c *** Unknown tensor
76 write (luout,1001) token(1:1)
77 return
78 c
79 c----------------------------------------------------------------------
80 c Tensor found: Check existing symmetry
81 c----------------------------------------------------------------------
82 else
83 ixf=iiwflg+(ixa-iwxx)/3
84 ixten=iwxx+3*(ixf-iiwflg)
85 c
86 c----------------------------------------------------------------------
87 c Check whether any tensor components of another symmetry
88 c are in the list of variable parameters
89 c----------------------------------------------------------------------
90 c
91 do 12 jx=jx1,jx2
92 if (ix2.le.0) then
93 tnstr=token(1:1)
94 else
95 write(tnstr,1004) token(1:1),jx
96 end if
97 c
98 do i=0,2
99 j=ixten+i
100 if (ixx(j,jx).ne.0) then
101 varstr=tag(ixx(j,jx))
102 write (luttyo,1005) tnstr(:itrim(tnstr)),
103 # varstr(:itrim(varstr))
104 return
105 end if
106 end do
107 c
108 c----------------------------------------------------------------------
109 c Symmetry not set yet: set it
110 c----------------------------------------------------------------------
111 if(iparm(ixf,jx) .eq. 0) then
112 iparm(ixf,jx)=iflg
113 if (jx.eq.jx1)
114 # write(luttyo,1002) tnstr(:itrim(tnstr)),
115 # symstr(iflg)(:itrim(symstr(iflg)))
116 go to 12
117 c
118 c----------------------------------------------------------------------
119 c Symmetry setting is same as the one specified: skip
120 c----------------------------------------------------------------------
121 else if (iparm(ixf,jx).eq.iflg) then
122 go to 12
123 end if
124 c
125 c----------------------------------------------------------------------
126 c Now...convert the tensor symmetry!
127 c----------------------------------------------------------------------
128 if (iflg.eq.spherical) then
129 call tosphr( fparm(ixten,jx),iparm(ixf,jx) )
130 else if (iflg.eq.axial) then
131 call toaxil( fparm(ixten,jx),iparm(ixf,jx) )
132 else
133 call tocart( fparm(ixten,jx),iparm(ixf,jx) )
134 end if
135 iparm(ixf,jx)=iflg
136 if (jx.eq.jx1)
137 # write (luttyo,1003) tnstr(:itrim(tnstr)),
138 # symstr(iflg)(:itrim(symstr(iflg)))
139 12 continue
140 end if
141 c
142 return
143 c
144 1000 format('*** No tensor specified ***')
145 1001 format('*** Unknown tensor: ''',a,''' ***')
146 1002 format('*** ',a,' tensor set to ',a,' ***')
147 1003 format('*** ',a,' tensor converted to ',a,' ***')
148 1004 format(a1,'(',i1,') ')
149 1005 format('*** ',a,' tensor symmetry unchanged: ',a,
150 # ' is being varied ***')
151 1006 format('*** CONVERT called with illegal symmetry type ***')
152 end
stdio::luout
integer, save luout
Definition: stdio.f90:32
eprprm::iiwflg
integer, parameter iiwflg
Definition: eprprm.f90:101
toaxil
subroutine toaxil(t, iflg)
Definition: tensym.f90:94
tocart
subroutine tocart(t, iflg)
Definition: tensym.f90:40
stdio
Definition: stdio.f90:26
parcom::fparm
double precision, dimension(nfprm, mxsite), target, save fparm
Definition: parcom.f90:54
symdef::axial
integer, parameter axial
Definition: symdef.f90:14
touppr
subroutine touppr(string, lth)
Definition: strutl2.f90:22
symdef::cartesian
integer, parameter cartesian
Definition: symdef.f90:14
parcom
Definition: parcom.f90:42
gettkn
subroutine gettkn(line, token, lth)
Written for free-form input of parameters for slow-motional calculations. Returns a token consisting ...
Definition: strutl1.f90:75
parcom::iparm
integer, dimension(niprm, mxsite), target, save iparm
Definition: parcom.f90:60
lpnam::symstr
character *10, dimension(nsymtr), save symstr
Definition: lpnam.f90:57
nlsdim::mxsite
integer, parameter mxsite
Definition: nlsdim.f90:39
eprprm::iwxx
integer, parameter iwxx
Definition: eprprm.f90:92
lpnam
Definition: lpnam.f90:18
stdio::luttyo
integer, parameter luttyo
Definition: stdio.f90:29
nlsdim::nalias
integer, parameter nalias
Definition: nlsdim.f90:57
eprprm
Definition: eprprm.f90:51
nlsdim
Definition: nlsdim.f90:36
parcom::ixx
integer, dimension(nfprm, mxsite), save ixx
Definition: parcom.f90:62
symdef::spherical
integer, parameter spherical
Definition: symdef.f90:14
convtc
subroutine convtc(line, iflg)
Definition: convtc.f90:26
tosphr
subroutine tosphr(t, iflg)
Definition: tensym.f90:66
parcom::tag
character *9, dimension(mxjcol), save tag
Definition: parcom.f90:67
symdef
Definition: symdef.f90:11