← Back to branch summary

~ubuntu-branches/debian/sid/pftools/sid

« back to all changes in this revision

Viewing changes to src/Fortran/regpr.f

  • Committer: Package Import Robot
  • Author(s): Andreas Tille
  • Date: 2017-03-31 14:01:39 UTC
  • Revision ID: package-import@ubuntu.com-20170331140139-povxg86r196gejfa
Tags: upstream-3+dfsg
Import upstream version 3+dfsg

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/Fortran/regpr.f
 
1
*----------------------------------------------------------------------*     
 
2
* $Id: regpr.f 150 2003-07-03 13:08:58Z vflegel $
 
3
*----------------------------------------------------------------------*     
 
4
*       Version:  File under developpment for release 2.3
 
5
*----------------------------------------------------------------------*     
 
6
      Subroutine REGPR
 
7
     *   (NGPR,FGPR,
 
8
     *   RG,RE,RF,RO,LSYM,
 
9
     *   CPID,CPAC,CPDE,NABC,CABC,LPRF,LPCI,
 
10
     *   CDIS,JDIP,MDIS,NDIP,
 
11
     *   CNOR,JNOP,JNOR,MNOR,NNOR,NNPR,CNTX,RNOP, 
 
12
     *   JCUT,MCLE,CCUT,ICUT,JCNM,RCUT,MCUT, 
 
13
     *   IDMP,CHIP,IIPP,CHMP,IMPP,
 
14
     *   CHID,IIPD,CHMD,IMPD,
 
15
     *   IRC)
 
16
 
 
17
      Character*(*)     FGPR
 
18
      Character*512     RCIN  
 
19
      Character         B
 
20
 
 
21
      Include          'psdat.f'
 
22
      Include          'gsdat.f'
 
23
      Include          'djdat.f'
 
24
      Include          'nodat.f'
 
25
      Include          'codat.f'
 
26
      Include          'pfdat.f'
 
27
      Include          'dfdat.f'
 
28
 
 
29
      Include          'sterr.f'
 
30
      
 
31
      Integer           IPRF(32)
 
32
      Character         CPRF
 
33
 
 
34
      Logical           LSYM
 
35
 
 
36
      Integer           Getc
 
37
 
 
38
      IRC=0
 
39
 
 
40
* open input file
 
41
      
 
42
      If(FGPR.EQ.'-') then
 
43
 1       Open(NGPR,Status='SCRATCH',Err=901)
 
44
 2       Continue 
 
45
         Do I1=1,512
 
46
            If(Getc(B).NE.0) go to 3
 
47
            If(Ichar(B).EQ.10) then
 
48
               Write(NGPR,'(512A)',Err=903)(RCIN(ii1:ii1),ii1=1,I1-1)
 
49
               Go to   2  
 
50
            Else
 
51
               RCIN(I1:I1)=B
 
52
            End if
 
53
         End do 
 
54
         Go to 905
 
55
 3       Rewind(NGPR)
 
56
      Else
 
57
         Open(NGPR,File=FGPR,Status='OLD',Err=900)
 
58
      End if
 
59
      
 
60
* initialize 
 
61
 
 
62
* - profile header
 
63
 
 
64
      CPID='GCG_PROFILE'
 
65
      CPAC='GC99999'
 
66
      CPDE='Automatically reformatted from file ''' 
 
67
     *   // FGPR(1:Lblnk(FGPR))
 
68
     *   // '''.' 
 
69
 
 
70
* - accessories
 
71
 
 
72
      LPCI=.FALSE.
 
73
 
 
74
      JNOR=1
 
75
      MNOR(1)=1
 
76
      NNOR(1)=1
 
77
      NNPR(1)=1   
 
78
      CNTX(1)='OrigScore'
 
79
      RNOP(1,1)=0.0
 
80
      RNOP(2,1)=1/RF
 
81
 
 
82
      JCUT=1
 
83
      MCLE(1)=0
 
84
      CCUT(1)=' '
 
85
      ICUT(1)=0
 
86
      JCNM(1)=1
 
87
      RCUT(1,1)=0.0
 
88
      MCUT(1,1)=1 
 
89
 
 
90
* - defaults for match and insert position  
 
91
 
 
92
      CHID='-'
 
93
      Do  15 I1=1,26 
 
94
         IIPD(I1)=0
 
95
 15   Continue
 
96
      
 
97
      IIPD(B0)=0
 
98
      IIPD(B1)=NLOW
 
99
      IIPD(E0)=0
 
100
      IIPD(E1)=NLOW
 
101
 
 
102
      IIPD(BM)=0
 
103
      IIPD(BI)=NLOW
 
104
      IIPD(BD)=NLOW
 
105
      IIPD(BE)=NLOW
 
106
      IIPD(MM)=0
 
107
      IIPD(MI)=NLOW
 
108
      IIPD(MD)=NLOW
 
109
      IIPD(ME)=0
 
110
      IIPD(IM)=0
 
111
      IIPD(II)=0
 
112
      IIPD(ID)=NLOW
 
113
      IIPD(IE)=NLOW
 
114
      IIPD(DM)=0
 
115
      IIPD(DI)=NLOW
 
116
      IIPD(DD)=0
 
117
      IIPD(DE)=NLOW
 
118
 
 
119
      IIPD(I0)=0
 
120
 
 
121
      CHMD='X'
 
122
      Do  16 I1=1,26 
 
123
         IMPD(I1)=0
 
124
 16   Continue
 
125
 
 
126
      IIPD(M0)=0 
 
127
      IMPD(D )=0
 
128
 
 
129
      Do  18 I1=0,27
 
130
         IMPP(I1,0)=NLOW
 
131
 18   Continue 
 
132
 
 
133
* read alphabet
 
134
 
 
135
 25   Read(NGPR,'(A)',End=905,Err=902) RCIN
 
136
      If(RCIN( 1: 4).NE.'Cons') go to  25
 
137
      
 
138
      IC1=Index(RCIN,'Gap')
 
139
      K1=0
 
140
      Do  29 I1=5,IC1-1
 
141
         If(RCIN(I1:I1).NE.' ') then
 
142
            K1=K1+1
 
143
            CABC(K1)=RCIN(I1:I1)
 
144
         End if
 
145
 29   Continue
 
146
      NABC=K1
 
147
 
 
148
* read numbers
 
149
 
 
150
      K1=0
 
151
 30   Read(NGPR,'(A)',End= 50,Err=902) RCIN
 
152
      If(RCIN( 1: 1).EQ.'!') go to  30
 
153
 
 
154
* - input line
 
155
 
 
156
C      RCIN(1024:1024)='@'
 
157
      CPRF=RCIN(2:2)
 
158
      Read(RCIN(3:512),*,Err=910,End= 50)
 
159
     *   (IPRF(ii1),ii1=1,NABC+2)
 
160
      Do  34 I2=1,NABC
 
161
         IPRF(I2)=NINT(Real(IPRF(I2))/100*RF+RO)
 
162
 34   Continue
 
163
      If(LSYM) then 
 
164
         NGO=-NINT(Real(IPRF(NABC+1))/200*RF*RG)
 
165
      Else
 
166
         NGO=-NINT(Real(IPRF(NABC+1))/100*RF*RG)
 
167
      End if 
 
168
      NGE=-NINT(Real(IPRF(NABC+2))/100*RF*RE)
 
169
 
 
170
* - build insert position 
 
171
 
 
172
      CHIP(K1)=CHID 
 
173
      Do  36 I1=0,46
 
174
         IIPP(I1,K1)=IIPD(I1)
 
175
 36   Continue
 
176
      Do  37 I1=1,NABC
 
177
         IIPP(I1,K1)=NGE
 
178
 37   Continue
 
179
      IIPP(MI,K1)=NGO
 
180
      IIPP(MD,K1)=NGO
 
181
      If(LSYM) then
 
182
         IIPP(IM,K1)=NGO
 
183
         IIPP(DM,K1)=NGO
 
184
      End if 
 
185
 
 
186
* - build match position
 
187
 
 
188
      K1=K1+1
 
189
      If(K1.GT.IDMP) go to 915
 
190
      CHMP(K1)=CPRF
 
191
      Do  43 I1=1,NABC
 
192
         IMPP(I1,K1)=IPRF(I1)
 
193
 43   Continue 
 
194
      IMPP( 0,K1)=0
 
195
      IMPP(D ,K1)=NGE
 
196
 
 
197
      Go to  30
 
198
 
 
199
 50   LPRF=K1
 
200
      If(LPRF.LE.0) go to 920
 
201
 
 
202
* - disjointness definition
 
203
 
 
204
      MDIS=2
 
205
      NDIP(1)=1+LPRF/10
 
206
      NDIP(2)=LPRF-LPRF/10
 
207
 
 
208
* - defaults for gap weights
 
209
 
 
210
      NGO=IIPP(MI,0) 
 
211
      NGE=IMPP( D,1) 
 
212
      Do  53 I1=1,LPRF-1
 
213
         NGO=MIN(NGO,IIPP(MI,I1))
 
214
         NGE=MIN(NGE,IMPP( D,I1+1))
 
215
 53   Continue
 
216
 
 
217
      IIPD(MI)=NGO
 
218
      IIPD(MD)=NGO
 
219
      If(LSYM) then 
 
220
         IIPD(DM)=NGO
 
221
         IIPD(IM)=NGO
 
222
      End if
 
223
      
 
224
      Do  54 I1=1,NABC
 
225
         IIPD(I1)=NGE
 
226
 54   Continue 
 
227
      IMPD( D)=NGE
 
228
 
 
229
* - last insert position 
 
230
 
 
231
      CHIP(K1)=CHID 
 
232
      Do  60 I1=0,46
 
233
         IIPP(I1,K1)=IIPD(I1)
 
234
 60   Continue
 
235
 
 
236
* - domain global mode:
 
237
 
 
238
      IIPP(B1,   0)=0
 
239
      IIPP(E1,LPRF)=0
 
240
 
 
241
* - move DM scores one position forward: 
 
242
 
 
243
      If(LSYM) then
 
244
         IIPP(DM, 0)=IIPD(DM)
 
245
         Do  65 I1=LPRF, 1,-1
 
246
            IIPP(DM,I1)=IIPP(DM,I1-1)
 
247
 65      Continue
 
248
      End if  
 
249
 
 
250
 100  Return 
 
251
 
 
252
* errors
 
253
 
 
254
 900  Write(NERR,*) 'Error: Unable to open profile file'//
 
255
     *   ' ''',FGPR(1:Lblnk(FGPR)),'''.'
 
256
      IRC=1
 
257
      Go to 100
 
258
 901  Write(NERR,*) 'Error: Unable to create temporary file.'
 
259
      IRC=1
 
260
      Go to 100
 
261
 902  Write(NERR,*) 'Error: Unable to read profile file.'
 
262
      IRC=1
 
263
      Go to 100
 
264
 903  Write(NERR,*) 'Error: Unable to write to temporary file.'
 
265
      IRC=1
 
266
      Go to 100
 
267
 905  Write(NERR,*) 'Error: Unexpected end of file. '//
 
268
     *   'Unable to find profile alphabet.'
 
269
      IRC=1
 
270
      Go to 100
 
271
 910  Write(NERR,*) 'Error: Unable to read profile values.'
 
272
      Write(NERR,*) '       at line: ',
 
273
     *   RCIN(1:Lblnk(RCIN))
 
274
      IRC=1
 
275
      Go to 100
 
276
 915  Write(NERR,*) 'Error: Profile length exceeds buffer size (',
 
277
     *   IDMP,').'
 
278
      IRC=1
 
279
      Go to 100
 
280
 920  Write(NERR,*) 'Error: Unexpected end of profile. Profile has '//
 
281
     *   'zero length. Check profile syntax.'
 
282
      IRC=1
 
283
      Go to 100
 
284
 
 
285
      End