← Back to branch summary

~ubuntu-branches/ubuntu/saucy/nwchem/saucy

« back to all changes in this revision

Viewing changes to src/smd/graveyard/smd-serial/smd_coords.F

  • Committer: Package Import Robot
  • Author(s): Michael Banck, Michael Banck, Daniel Leidert
  • Date: 2012-02-09 20:02:41 UTC
  • mfrom: (1.1.1)
  • Revision ID: package-import@ubuntu.com-20120209200241-jgk03qfsphal4ug2
Tags: 6.1-1
http://bugs.debian.org/632611
https://launchpad.net/bugs/791308
* New upstream release.

[ Michael Banck ]
* debian/patches/02_makefile_flags.patch: Updated.
* debian/patches/02_makefile_flags.patch: Use internal blas and lapack code.
* debian/patches/02_makefile_flags.patch: Define GCC4 for LINUX and LINUX64
  (Closes: #632611 and LP: #791308).
* debian/control (Build-Depends): Added openssh-client.
* debian/rules (USE_SCALAPACK, SCALAPACK): Removed variables (Closes:
  #654658).
* debian/rules (LIBDIR, USE_MPIF4, ARMCI_NETWORK): New variables.
* debian/TODO: New file.
* debian/control (Build-Depends): Removed libblas-dev, liblapack-dev and
  libscalapack-mpi-dev.
* debian/patches/04_show_testsuite_diff_output.patch: New patch, shows the
  diff output for failed tests.
* debian/patches/series: Adjusted.
* debian/testsuite: Optionally run all tests if "all" is passed as option.
* debian/rules: Run debian/testsuite with "all" if DEB_BUILD_OPTIONS
  contains "checkall".

[ Daniel Leidert ]
* debian/control: Used wrap-and-sort. Added Vcs-Svn and Vcs-Browser fields.
  (Priority): Moved to extra according to policy section 2.5.
  (Standards-Version): Bumped to 3.9.2.
  (Description): Fixed a typo.
* debian/watch: Added.
* debian/patches/03_hurd-i386_define_path_max.patch: Added.
  - Define MAX_PATH if not defines to fix FTBFS on hurd.
* debian/patches/series: Adjusted.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/smd/graveyard/smd-serial/smd_coords.F
 
1
      subroutine smd_coords_init_system()
 
2
      implicit none
 
3
#include "errquit.fh"
 
4
#include "inp.fh"
 
5
#include "mafdecls.fh"
 
6
#include "rtdb.fh"
 
7
#include "util.fh"
 
8
#include "global.fh"
 
9
c     
 
10
      character*32 sp_coords,sp_atom
 
11
      character*32 tag,pname
 
12
      logical result
 
13
 
 
14
      pname = "smd_coords_init_system"
 
15
c
 
16
      tag = "atom"
 
17
      call smd_system_get_component(sp_atom,tag,result)
 
18
      if(.not.result)
 
19
     >  call errquit(
 
20
     >       pname//'no component '//tag,0,0)
 
21
 
 
22
      tag = "coordinates"
 
23
      call smd_system_get_component(sp_coords,tag,result)
 
24
      if(.not.result)
 
25
     >  call errquit(
 
26
     >       pname//'no component '//tag,0,0)
 
27
 
 
28
      call smd_coords_init(sp_coords)
 
29
      
 
30
      call smd_coords_read(sp_coords)
 
31
c
 
32
      return
 
33
      end
 
34
 
 
35
      subroutine smd_coords_init(sp_coords)
 
36
      implicit none
 
37
#include "errquit.fh"
 
38
#include "inp.fh"
 
39
#include "mafdecls.fh"
 
40
#include "rtdb.fh"
 
41
#include "util.fh"
 
42
#include "global.fh"
 
43
c     
 
44
      character*(*) sp_coords
 
45
c
 
46
      character*32 pname
 
47
      integer na
 
48
c
 
49
      pname = "smd_coords_init"
 
50
c
 
51
c      write(*,*) "in "//pname
 
52
c
 
53
c     get total number of atoms 
 
54
c     -------------------------
 
55
      call smd_atom_ntot(na)
 
56
      if(na.le.0)
 
57
     >  call errquit(
 
58
     >       pname//'no atoms ',0, RTDB_ERR)
 
59
c
 
60
c     create coords data structures
 
61
c     ---------------------------
 
62
      call smd_namespace_create(sp_coords)
 
63
      call smd_data_create(sp_coords,"coords",3*na,MT_DBL)
 
64
 
 
65
      return
 
66
      end
 
67
 
 
68
      subroutine smd_coords_read(sp_coords)
 
69
      implicit none
 
70
#include "errquit.fh"
 
71
#include "inp.fh"
 
72
#include "mafdecls.fh"
 
73
#include "rtdb.fh"
 
74
#include "util.fh"
 
75
#include "global.fh"
 
76
c     
 
77
      character*(*) sp_coords
 
78
      integer rtdb
 
79
c
 
80
      character*32 pname
 
81
      character*72 tag
 
82
      integer i_c
 
83
      integer na
 
84
      logical result
 
85
c
 
86
      pname = "smd_coords_read"
 
87
c
 
88
c      write(*,*) "in "//pname
 
89
c
 
90
c     fill in coordinates from pdb file if any
 
91
c     ----------------------------------------
 
92
      tag = "coords"
 
93
      call smd_get_ind_size(tag,i_c,na,result)
 
94
      if(.not. result) 
 
95
     >  call errquit(
 
96
     >       pname//'error getting index for '//tag,0, RTDB_ERR)
 
97
c
 
98
      na = na/3
 
99
 
 
100
 
 
101
      call smd_coordfile_read_coords(na,
 
102
     +                          dbl_mb(i_c))
 
103
 
 
104
 
 
105
      return
 
106
      end
 
107
 
 
108
      subroutine smd_coords_rebox()
 
109
      implicit none
 
110
#include "errquit.fh"
 
111
#include "inp.fh"
 
112
#include "mafdecls.fh"
 
113
#include "rtdb.fh"
 
114
#include "util.fh"
 
115
#include "global.fh"
 
116
c     
 
117
      character*32 sp_coords
 
118
c
 
119
      character*72 tag
 
120
      character*30 pname
 
121
      integer na
 
122
      integer i_c,i_lrc,i_lc
 
123
      logical result
 
124
 
 
125
      pname = "smd_coords_rebox"
 
126
 
 
127
c
 
128
c     get atomic coordinates
 
129
c     ----------------------
 
130
      tag = "coords"
 
131
      call smd_get_ind_size(tag,i_c,na,result)
 
132
      if(.not. result)
 
133
     >  call errquit(
 
134
     >       pname//'error getting index for '//tag,0, RTDB_ERR)
 
135
      na = na/3
 
136
 
 
137
      call smd_lat_rebox(na,
 
138
     >                    dbl_mb(i_c))
 
139
 
 
140
      return
 
141
      end
 
142
 
 
143
      subroutine smd_coords_print(un)
 
144
      implicit none
 
145
#include "errquit.fh"
 
146
#include "inp.fh"
 
147
#include "mafdecls.fh"
 
148
#include "rtdb.fh"
 
149
#include "util.fh"
 
150
#include "global.fh"
 
151
c     
 
152
      integer un
 
153
      character*32 sp_coords
 
154
c
 
155
      character*72 tag
 
156
      character*30 pname
 
157
      integer na
 
158
      integer i_c,i_lrc,i_lc
 
159
      logical result
 
160
 
 
161
      pname = "smd_coords_print"
 
162
 
 
163
c
 
164
c     get atomic coordinates
 
165
c     ----------------------
 
166
      tag = "coords"
 
167
      call smd_get_ind(tag,i_c,na,result)
 
168
      if(.not. result)
 
169
     >  call errquit(
 
170
     >       pname//'error getting index for '//tag,0, RTDB_ERR)
 
171
      na = na/3
 
172
 
 
173
      write(un,*) "printing coord" 
 
174
      call smd_util_print_force_array(un,na,
 
175
     >                           dbl_mb(i_c))  
 
176
 
 
177
      return
 
178
      end
 
179
 
 
180
      subroutine smd_coords_update()
 
181
      implicit none
 
182
#include "errquit.fh"
 
183
#include "inp.fh"
 
184
#include "mafdecls.fh"
 
185
#include "rtdb.fh"
 
186
#include "util.fh"
 
187
#include "smd_system.fh"
 
188
#include "smd_const_data.fh"
 
189
c     
 
190
      character*72 sp_vel
 
191
      character*72 sp_coords
 
192
      character*72 sp_mass
 
193
      character*72 sp_force
 
194
      character*72 sp_shakelist
 
195
      character*32 pname
 
196
      character*80 tag
 
197
      integer nt,na
 
198
      integer i_f
 
199
      integer i_m,i_c,i_v
 
200
      logical result
 
201
      integer rtdb
 
202
      double precision ekin, tstep
 
203
      logical oshake
 
204
      integer i_is1,i_is2,i_ds,ns
 
205
      integer h_ncc,i_ncc
 
206
      integer h_nvv,i_nvv
 
207
      integer h_dcc,i_dcc
 
208
      integer h_nrij,i_nrij
 
209
      integer h_orij,i_orij
 
210
c
 
211
      pname = "smd_coords_update"
 
212
c
 
213
c      write(*,*) "in "//pname
 
214
c
 
215
      call  smd_rtdb_get_handle(rtdb)
 
216
c
 
217
c     get velocity array
 
218
c     ------------------
 
219
      tag = "vel"
 
220
      call smd_get_ind_size(tag,i_v,na,result)
 
221
      if(.not. result) 
 
222
     >  call errquit(
 
223
     >       pname//'error getting index for'//tag,0, 0)
 
224
      na = na/3
 
225
 
 
226
c
 
227
c     get mass array
 
228
c     ------------------
 
229
      tag = "mass"
 
230
      call smd_get_ind(tag,i_m,result)
 
231
      if(.not. result) 
 
232
     >  call errquit(
 
233
     >       pname//'error getting index for'//tag,0, 0)
 
234
c
 
235
c     get force array
 
236
c     ---------------
 
237
      tag = "force"
 
238
      call smd_get_ind(tag,i_f,result)
 
239
      if(.not. result) 
 
240
     >  call errquit(
 
241
     >       pname//'error getting index for'//tag,0, 0)
 
242
 
 
243
c
 
244
c     get coord array
 
245
c     ---------------
 
246
      tag = "coords"
 
247
      call smd_get_ind(tag,i_c,result)
 
248
      if(.not. result) 
 
249
     >  call errquit(
 
250
     >       pname//'error getting index for'//tag,0, 0)
 
251
 
 
252
c
 
253
c     get time step
 
254
c     -------------
 
255
      tag="smd:step"
 
256
        if (.not.rtdb_get(rtdb,tag,mt_dbl,1,tstep)) 
 
257
     >      call errquit(pname//'failed to store'//tag,0,
 
258
     >       RTDB_ERR)
 
259
 
 
260
 
 
261
      oshake = smd_system_shake()
 
262
 
 
263
      if(oshake) then
 
264
 
 
265
        tag = "shake:i1"
 
266
        call smd_get_ind(tag,i_is1,result)
 
267
        if(.not. result) 
 
268
     >    call errquit(
 
269
     >         pname//'error getting index for '//tag,0, 0)
 
270
 
 
271
        tag = "shake:i2"
 
272
        call smd_get_ind(tag,i_is2,result)
 
273
        if(.not. result) 
 
274
     >    call errquit(
 
275
     >         pname//'error getting index for '//tag,0, 0)
 
276
 
 
277
        tag = "shake:distance"
 
278
        call smd_get_ind_size(tag,i_ds,ns,result)
 
279
        if(.not. result) 
 
280
     >    call errquit(
 
281
     >         pname//'error getting index for '//tag,0, 0)
 
282
 
 
283
        if(.not.ma_push_get(mt_dbl,na*3,'i_ncc',h_ncc,i_ncc))
 
284
     +   call errquit(pname//'Failed to allocate memory',
 
285
     +   0, MA_ERR)
 
286
 
 
287
        if(.not.ma_push_get(mt_dbl,na*3,'i_nvv',h_nvv,i_nvv))
 
288
     +   call errquit(pname//'Failed to allocate memory',
 
289
     +   0, MA_ERR)
 
290
 
 
291
        if(.not.ma_push_get(mt_dbl,na*3,'i_dcc',h_dcc,i_dcc))
 
292
     +   call errquit(pname//'Failed to allocate memory',
 
293
     +   0, MA_ERR)
 
294
 
 
295
        if(.not.ma_push_get(mt_dbl,ns*3,'i_nrij',h_nrij,i_nrij))
 
296
     +   call errquit(pname//'Failed to allocate memory',
 
297
     +   0, MA_ERR)
 
298
 
 
299
        if(.not.ma_push_get(mt_dbl,ns*3,'i_orij',h_orij,i_orij))
 
300
     +   call errquit(pname//'Failed to allocate memory',
 
301
     +   0, MA_ERR)
 
302
 
 
303
      end if
 
304
      if(oshake) then
 
305
       call smd_leapf_shake(na,
 
306
     >                           ns,
 
307
     >                           tstep,
 
308
     >                           ekin,
 
309
     >                           dbl_mb(i_m),
 
310
     >                           int_mb(i_is1),
 
311
     >                           int_mb(i_is2),
 
312
     >                           dbl_mb(i_ds),
 
313
     >                           dbl_mb(i_ncc),
 
314
     >                           dbl_mb(i_nvv),
 
315
     >                           dbl_mb(i_dcc),
 
316
     >                           dbl_mb(i_nrij),
 
317
     >                           dbl_mb(i_orij),
 
318
     >                           dbl_mb(i_f),
 
319
     >                           dbl_mb(i_v),
 
320
     >                           dbl_mb(i_c))
 
321
 
 
322
 
 
323
      else
 
324
      call smd_leapf(na,
 
325
     >                 tstep,
 
326
     >                 ekin,
 
327
     >                 dbl_mb(i_m),
 
328
     >                 dbl_mb(i_f),
 
329
     >                 dbl_mb(i_v),
 
330
     >                 dbl_mb(i_c))
 
331
 
 
332
      end if
 
333
 
 
334
      call smd_energy_set_component("kinetic",ekin/convfct2)
 
335
      call smd_coords_rebox()
 
336
 
 
337
      
 
338
      if(oshake) then
 
339
 
 
340
        if(.not.ma_pop_stack(h_orij))
 
341
     &   call errquit(pname//'Failed to deallocate stack h_orij',0,
 
342
     &         MA_ERR)
 
343
 
 
344
        if(.not.ma_pop_stack(h_nrij))
 
345
     &   call errquit(pname//'Failed to deallocate stack h_nrij',0,
 
346
     &         MA_ERR)
 
347
 
 
348
        if(.not.ma_pop_stack(h_dcc))
 
349
     &   call errquit(pname//'Failed to deallocate stack h_dcc',0,
 
350
     &         MA_ERR)
 
351
 
 
352
        if(.not.ma_pop_stack(h_nvv))
 
353
     &   call errquit(pname//'Failed to deallocate stack h_nvv',0,
 
354
     &         MA_ERR)
 
355
 
 
356
 
 
357
        if(.not.ma_pop_stack(h_ncc))
 
358
     &   call errquit(pname//'Failed to deallocate stack h_ncc',0,
 
359
     &         MA_ERR)
 
360
 
 
361
      end if
 
362
 
 
363
      return
 
364
      end
 
365
 
 
366
      subroutine smd_coords_print_pdb(fname)
 
367
      implicit none
 
368
#include "errquit.fh"
 
369
#include "inp.fh"
 
370
#include "mafdecls.fh"
 
371
#include "rtdb.fh"
 
372
#include "util.fh"
 
373
#include "global.fh"
 
374
#include "smd_const_data.fh"
 
375
      character*(*) fname
 
376
c     
 
377
      integer un
 
378
      character*32 sp_coords
 
379
c
 
380
      character*72 tag
 
381
      character*30 pname
 
382
      integer na
 
383
      integer i,i0,j
 
384
      integer i_c,i_ta,i_tr,i_ir
 
385
      logical result
 
386
c
 
387
      pname = "smd_coords_print"
 
388
c
 
389
      if(.not.util_get_io_unit(un)) 
 
390
     >   call errquit("cannot get file number",0,0)
 
391
      open(unit=un,status="unknown",form="formatted",file=fname)
 
392
c
 
393
c     get atomic coordinates
 
394
c     ----------------------
 
395
      tag = "coords"
 
396
      call smd_get_ind_size(tag,i_c,na,result)
 
397
      if(.not. result)
 
398
     >  call errquit(
 
399
     >       pname//'error getting index for '//tag,0, RTDB_ERR)
 
400
      na = na/3
 
401
c
 
402
      tag = "atom:name"
 
403
      call smd_get_ind(tag,i_ta,result)
 
404
      if(.not. result)
 
405
     >  call errquit(
 
406
     >       pname//'error getting index for '//tag,0, RTDB_ERR)
 
407
c
 
408
      tag = "atom:resid"
 
409
      call smd_get_ind(tag,i_ir,result)
 
410
      if(.not. result)
 
411
     >  call errquit(
 
412
     >       pname//'error getting index for '//tag,0, RTDB_ERR)
 
413
c
 
414
      tag = "atom:resname"
 
415
      call smd_get_ind(tag,i_tr,result)
 
416
      if(.not. result)
 
417
     >  call errquit(
 
418
     >       pname//'error getting index for '//tag,0, RTDB_ERR)
 
419
 
 
420
 
 
421
      do i=1,na
 
422
       i0=smd_string_size*(i-1)
 
423
       write(un,FMT=9000)
 
424
     >           i,
 
425
     >           (byte_mb(i_ta+i0+j-1),j=1,4),
 
426
     >           (byte_mb(i_tr+i0+j-1),j=1,3),
 
427
     >            int_mb(i_ir+i-1),
 
428
     >            dbl_mb(i_c+(i-1)),
 
429
     >            dbl_mb(i_c+(i-1)+na),
 
430
     >            dbl_mb(i_c+(i-1)+2*na)
 
431
 
 
432
      end do
 
433
      close(un)
 
434
9000  FORMAT("ATOM",T7,I5,T13,4A,T18,3A,T23,
 
435
     >       I4,T31,F8.3,T39,F8.3,T47,F8.3)
 
436
 
 
437
      return
 
438
      end
 
439
 
 
440
      subroutine smd_coords_print_pdb1(fname,c)
 
441
      implicit none
 
442
#include "errquit.fh"
 
443
#include "inp.fh"
 
444
#include "mafdecls.fh"
 
445
#include "rtdb.fh"
 
446
#include "util.fh"
 
447
#include "global.fh"
 
448
#include "smd_const_data.fh"
 
449
      character*(*) fname
 
450
      double precision c(*)
 
451
c     
 
452
      integer un
 
453
      character*32 sp_coords
 
454
c
 
455
      character*72 tag
 
456
      character*30 pname
 
457
      integer na
 
458
      integer i,i0,j
 
459
      integer i_c,i_ta,i_tr,i_ir
 
460
      logical result
 
461
c
 
462
      pname = "smd_coords_print"
 
463
c
 
464
      if(.not.util_get_io_unit(un)) 
 
465
     >   call errquit("cannot get file number",0,0)
 
466
      open(unit=un,status="unknown",form="formatted",file=fname)
 
467
c
 
468
c     get atomic coordinates
 
469
c     ----------------------
 
470
      tag = "coords"
 
471
      call smd_get_ind_size(tag,i_c,na,result)
 
472
      if(.not. result)
 
473
     >  call errquit(
 
474
     >       pname//'error getting index for '//tag,0, RTDB_ERR)
 
475
      na = na/3
 
476
c
 
477
      tag = "atom:name"
 
478
      call smd_get_ind(tag,i_ta,result)
 
479
      if(.not. result)
 
480
     >  call errquit(
 
481
     >       pname//'error getting index for '//tag,0, RTDB_ERR)
 
482
c
 
483
      tag = "atom:resid"
 
484
      call smd_get_ind(tag,i_ir,result)
 
485
      if(.not. result)
 
486
     >  call errquit(
 
487
     >       pname//'error getting index for '//tag,0, RTDB_ERR)
 
488
c
 
489
      tag = "atom:resname"
 
490
      call smd_get_ind(tag,i_tr,result)
 
491
      if(.not. result)
 
492
     >  call errquit(
 
493
     >       pname//'error getting index for '//tag,0, RTDB_ERR)
 
494
 
 
495
 
 
496
      do i=1,na
 
497
       i0=smd_string_size*(i-1)
 
498
       write(un,FMT=9000)
 
499
     >           i,
 
500
     >           (byte_mb(i_ta+i0+j-1),j=1,4),
 
501
     >           (byte_mb(i_tr+i0+j-1),j=1,3),
 
502
     >            int_mb(i_ir+i-1),
 
503
     >            c(i),
 
504
     >            c(i+na),
 
505
     >            c(i+2*na)
 
506
 
 
507
      end do
 
508
      close(un)
 
509
9000  FORMAT("ATOM",T7,I5,T13,4A,T18,3A,T23,
 
510
     >       I4,T31,F8.3,T39,F8.3,T47,F8.3)
 
511
 
 
512
      return
 
513
      end