add_subdirectory(source/xdrfpdb/src)
add_subdirectory(source/xdrfpdb/src-M)
add_subdirectory(source/wham/src)
+ add_subdirectory(source/wham/src-M)
endif(UNRES_WITH_MPI)
add_subdirectory(source/unres/src_MIN)
set(FFLAGS2 "-w -g -00 ")
set(FFLAGS3 "-g -w -ipo " )
elseif (Fortran_COMPILER_NAME STREQUAL "gfortran")
- set(FFLAGS0 " " )
+ set(FFLAGS0 "-O" )
set(FFLAGS1 "-g -C" )
set(FFLAGS2 "-g -O0 ")
set(FFLAGS3 "-O3" )
--- /dev/null
+#
+# CMake project file for WHAM multichain version
+#
+
+enable_language (Fortran)
+
+#================================
+# Set source file lists
+#================================
+set(UNRES_WHAM_M_SRC0
+ wham_multparm.F
+ bxread.F
+ xread.F
+ cxread.F
+ enecalc1.F
+ energy_p_new.F
+ initialize_p.F
+ molread_zs.F
+ openunits.F
+ readrtns.F
+ arcos.f
+ cartder.f
+ cartprint.f
+ chainbuild.F
+ geomout.F
+ icant.f
+ intcor.f
+ int_from_cart.f
+ make_ensemble1.F
+ matmult.f
+ misc.f
+ mygetenv.F
+ parmread.F
+ pinorm.f
+ printmat.f
+ rescode.f
+ setup_var.f
+ slices.F
+ store_parm.F
+ timing.F
+ wham_calc1.F
+ readrtns_compar.F
+ readpdb.f
+ fitsq.f
+ contact.f
+ elecont.f
+ contfunc.f
+ cont_frag.f
+ conf_compar.F
+ match_contact.f
+ angnorm.f
+ odlodc.f
+ promienie.f
+ qwolynes.f
+ read_ref_str.F
+ rmscalc.f
+ secondary.f
+ proc_cont.f
+ define_pairs.f
+ mysort.f
+)
+
+set(UNRES_WHAM_M_PP_SRC
+ bxread.F
+ chainbuild.F
+ conf_compar.F
+ cxread.F
+ enecalc1.F
+ energy_p_new.F
+ geomout.F
+ initialize_p.F
+ make_ensemble1.F
+ molread_zs.F
+ mygetenv.F
+ openunits.F
+ parmread.F
+ read_ref_str.F
+ readrtns_compar.F
+ readrtns.F
+ slices.F
+ store_parm.F
+ timing.F
+ wham_calc1.F
+ wham_multparm.F
+ xread.F
+ proc_proc.c
+)
+
+
+#================================================
+# Set comipiler flags for different sourcefiles
+#================================================
+if (Fortran_COMPILER_NAME STREQUAL "ifort")
+ set(FFLAGS0 "-g -CB -I. -I${CMAKE_CURRENT_SOURCE_DIR}/include_unres -I${MPIF_INCLUDE_DIRECTORIES}" )
+elseif (Fortran_COMPILER_NAME STREQUAL "gfortran")
+ set(FFLAGS0 "-g -I. -I${CMAKE_CURRENT_SOURCE_DIR}/include_unres
+-I${MPIF_INCLUDE_DIRECTORIES}" )
+endif (Fortran_COMPILER_NAME STREQUAL "ifort")
+
+
+#=========================================
+# Add MPI compiler flags
+#=========================================
+if(UNRES_WITH_MPI)
+ set(FFLAGS0 "${FFLAGS0} -I${MPIF_INCLUDE_DIRECTORIES}")
+endif(UNRES_WITH_MPI)
+
+set_property(SOURCE ${UNRES_WHAM_M_SRC0} PROPERTY COMPILE_FLAGS ${FFLAGS0} )
+
+#=========================================
+# WHAM preprocesor flags
+#=========================================
+
+set(CPPFLAGS "PROCOR -DUNRES -DISNAN -DSPLITELE -DCRYST_BOND -DCRYST_THETA -DCRYST_SC" )
+
+#=========================================
+# System specific flags
+#=========================================
+if(${CMAKE_SYSTEM_NAME} MATCHES "Linux")
+ set(CPPFLAGS "${CPPFLAGS} -DLINUX")
+endif(${CMAKE_SYSTEM_NAME} MATCHES "Linux")
+
+#=========================================
+# Compiler specific flags
+#=========================================
+
+if (Fortran_COMPILER_NAME STREQUAL "ifort")
+ # Add ifort preprocessor flags
+ set(CPPFLAGS "${CPPFLAGS} -DPGI")
+elseif (Fortran_COMPILER_NAME STREQUAL "f95")
+ # Add new gfortran flags
+ set(CPPFLAGS "${CPPFLAGS} -DG77")
+elseif (Fortran_COMPILER_NAME STREQUAL "gfortran")
+ # Add old gfortran flags
+ set(CPPFLAGS "${CPPFLAGS} -DG77")
+endif (Fortran_COMPILER_NAME STREQUAL "ifort")
+
+#=========================================
+# Add MPI preprocessor flags
+#=========================================
+set(CPPFLAGS "${CPPFLAGS} -DMPI")
+
+#=========================================
+# Add 64-bit specific preprocessor flags
+#=========================================
+if (architektura STREQUAL "64")
+ set(CPPFLAGS "${CPPFLAGS} -DAMD64")
+endif (architektura STREQUAL "64")
+
+#=========================================
+# Apply preprocesor flags to *.F files
+#=========================================
+set_property(SOURCE ${UNRES_WHAM_M_PP_SRC} PROPERTY COMPILE_DEFINITIONS ${CPPFLAGS} )
+
+
+#========================================
+# Setting binary name
+#========================================
+set(UNRES_WHAM_M_BIN "wham_${Fortran_COMPILER_NAME}.exe")
+
+#=========================================
+# cinfo.f stupid workaround for cmake
+# - shame on me ]:)
+#=========================================
+set_property(SOURCE compinfo.c PROPERTY CMAKE_C_FLAGS "-c" )
+add_executable(compinfo-wham-m compinfo.c)
+set_target_properties(compinfo-wham-m PROPERTIES OUTPUT_NAME compinfo)
+
+set(UNRES_CINFO_DIR "${CMAKE_CURRENT_BINARY_DIR}" )
+add_custom_command(OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f
+ COMMAND ${CMAKE_COMMAND} -E copy ${CMAKE_CURRENT_SOURCE_DIR}/cinfo.f ${CMAKE_CURRENT_BINARY_DIR}/cinfo.f
+ COMMAND ${CMAKE_COMMAND} -E copy ${CMAKE_CURRENT_SOURCE_DIR}/COMMON.IOUNITS ${CMAKE_CURRENT_BINARY_DIR}/COMMON.IOUNITS
+ COMMAND ${CMAKE_CURRENT_BINARY_DIR}/compinfo | true
+ DEPENDS compinfo-wham-m )
+set_property(SOURCE ${UNRES_CINFO_DIR}/cinfo.f PROPERTY COMPILE_FLAGS ${FFLAGS0} )
+
+#=========================================
+# Set full unres CSA sources
+#=========================================
+set(UNRES_WHAM_M_SRCS ${UNRES_WHAM_M_SRC0} ${UNRES_CINFO_DIR}/cinfo.f proc_proc.c)
+
+#=========================================
+# Build the binary
+#=========================================
+add_executable(UNRES_WHAM_M_BIN ${UNRES_WHAM_M_SRCS} )
+set_target_properties(UNRES_WHAM_M_BIN PROPERTIES OUTPUT_NAME ${UNRES_WHAM_M_BIN})
+
+#set_property(TARGET ${UNRES_BIN} PROPERTY RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin/unres/MD )
+#add_dependencies (${UNRES_BIN} ${UNRES_XDRFLIB})
+
+#=========================================
+# Link libraries
+#=========================================
+# link MPI library (libmpich.a)
+target_link_libraries( UNRES_WHAM_M_BIN ${MPIF_LIBRARIES} )
+# link libxdrf.a
+target_link_libraries( UNRES_WHAM_M_BIN xdrf )
+
+#=========================================
+# TESTS
+#=========================================
+
+#-- Copy all the data files from the test directory into the source directory
+#SET(UNRES_TEST_FILES
+# ala10.inp
+# )
+
+#FOREACH (UNRES_TEST_FILE ${UNRES_TEST_FILES})
+# SET (unres_test_dest "${CMAKE_CURRENT_BINARY_DIR}/${UNRES_TEST_FILE}")
+# MESSAGE (STATUS " Copying ${UNRES_TEST_FILE} from ${CMAKE_SOURCE_DIR}/examples/unres/MD/ff_gab/${UNRES_TEST_FILE} to ${unres_test_dest}")
+# ADD_CUSTOM_COMMAND (
+# TARGET ${UNRES_BIN}
+# POST_BUILD
+# COMMAND ${CMAKE_COMMAND} -E copy ${CMAKE_SOURCE_DIR}/examples/unres/MD/ff_gab/${UNRES_TEST_FILE} ${unres_test_dest}
+# )
+#ENDFOREACH (UNRES_TEST_FILE ${UNRES_TEST_FILES})
+
+#=========================================
+# Generate data test files
+#=========================================
+# test_single_ala.sh
+#=========================================
+
+#FILE(WRITE ${CMAKE_CURRENT_BINARY_DIR}/test_single_ala.sh
+#"#!/bin/sh
+#export POT=GB
+#export PREFIX=ala10
+#-----------------------------------------------------------------------------
+#UNRES_BIN=./${UNRES_BIN}
+#-----------------------------------------------------------------------------
+#DD=${CMAKE_SOURCE_DIR}/PARAM
+#export BONDPAR=$DD/bond.parm
+#export THETPAR=$DD/thetaml.5parm
+#export ROTPAR=$DD/scgauss.parm
+#export TORPAR=$DD/torsion_631Gdp.parm
+#export TORDPAR=$DD/torsion_double_631Gdp.parm
+#export ELEPAR=$DD/electr_631Gdp.parm
+#export SIDEPAR=$DD/sc_GB_opt.1gab_3S_qclass5no310-shan2-sc-16-10-8k
+#export FOURIER=$DD/fourier_opt.parm.1igd_hc_iter3_3
+#export SCPPAR=$DD/scp.parm
+#export SCCORPAR=$DD/rotcorr_AM1.parm
+#export PATTERN=$DD/patterns.cart
+#-----------------------------------------------------------------------------
+#$UNRES_BIN
+#")
+
+#=========================================
+# ala10.inp
+#=========================================
+
+#file(WRITE ${CMAKE_CURRENT_BINARY_DIR}/ala10.inp
+#"ala10 unblocked
+#SEED=-1111333 MD ONE_LETTER rescale_mode=2 PDBOUT
+#nstep=15000 ntwe=100 ntwx=1000 dt=0.1 lang=0 tbf t_bath=300 damax=1.0 &
+#reset_moment=1000 reset_vel=1000 MDPDB
+#WLONG=1.35279 WSCP=1.59304 WELEC=0.71534 WBOND=1.00000 WANG=1.13873 &
+#WSCLOC=0.16258 WTOR=1.98599 WTORD=1.57069 WCORRH=0.42887 WCORR5=0.00000 &
+#WCORR6=0.00000 WEL_LOC=0.16036 WTURN3=1.68722 WTURN4=0.66230 WTURN6=0.00000 &
+#WVDWPP=0.11371 WHPB=1.00000 &
+#CUTOFF=7.00000 WCORR4=0.00000
+#12
+#XAAAAAAAAAAX
+# 0
+# 0
+# 90.0000 90.0000 90.0000 90.000 90.000 90.000 90.000 90.000
+# 90.0000 90.0000
+# 180.0000 180.0000 180.0000 180.000 180.000 180.000 180.000 180.000
+# 180.0000
+# 110.0000 110.0000 110.0000 100.000 110.000 100.000 110.000 110.000
+# 110.0000 110.0000
+# -120.0000 -120.0000 -120.000 -120.000 -120.000 -120.000 -120.000 -120.000
+# -120.0000 -120.0000
+#")
+
+
+# Add tests
+
+#if(NOT UNRES_WITH_MPI)
+
+# add_test(NAME UNRES_MD_Ala10 COMMAND sh ${CMAKE_CURRENT_BINARY_DIR}/test_single_ala.sh )
+
+#endif(NOT UNRES_WITH_MPI)
fprintf(out," write(iout,*)'Version %d.%-d build %d'\n",iv1,iv2,iv3);
uname(&Name);
time(&Tp);
-system("rm tmptmp; whoami > tmptmp");
+system("whoami > tmptmp");
in1=fopen("tmptmp","r");
fscanf(in1,"%s",buf1);
fclose(in1);
+system("rm tmptmp");
p1=ctime(&Tp);
p1[strlen(p1)-1]='\0';
fprintf(out," write(iout,*)'compiled %s'\n",p1);
fprintf(out," write(iout,*)'compiled by %s@%s'\n",buf1,Name.nodename);
fprintf(out," write(iout,*)'OS name: %s '\n",Name.sysname);
fprintf(out," write(iout,*)'OS release: %s '\n",Name.release);
-fprintf(out," write(iout,*)'OS version: %s '\n",Name.version);
+fprintf(out," write(iout,*)'OS version:',\n");
+fprintf(out," & ' %s '\n",Name.version);
fprintf(out," write(iout,*)'flags:'\n");
in1=fopen("Makefile","r");
while(fgets(buf,498,in1) != NULL)
+++ /dev/null
-1c1
-< subroutine etotal(energia,fact)
----
-> subroutine etotal(energia)
-4,5d3
-< include 'DIMENSIONS.ZSCOPT'
-<
-8d5
-< #endif
-12,18d8
-<
-< include 'COMMON.IOUNITS'
-< double precision energia(0:max_ene),energia1(0:max_ene+1)
-< #ifdef MPL
-< include 'COMMON.INFO'
-< external d_vadd
-< integer ready
-19a10,17
-> #ifdef MPI
-> include "mpif.h"
-> double precision weights_(n_ene)
-> #endif
-> include 'COMMON.SETUP'
-> include 'COMMON.IOUNITS'
-> double precision energia(0:n_ene)
-> include 'COMMON.LOCAL'
-25,28c23,98
-< double precision fact(6)
-< cd write(iout, '(a,i2)')'Calling etotal ipot=',ipot
-< cd print *,'nnt=',nnt,' nct=',nct
-< C
----
-> include 'COMMON.VAR'
-> include 'COMMON.MD'
-> include 'COMMON.CONTROL'
-> include 'COMMON.TIME1'
-> #ifdef MPI
-> c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
-> c & " nfgtasks",nfgtasks
-> if (nfgtasks.gt.1) then
-> time00=MPI_Wtime()
-> C FG slaves call the following matching MPI_Bcast in ERGASTULUM
-> if (fg_rank.eq.0) then
-> call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
-> c print *,"Processor",myrank," BROADCAST iorder"
-> C FG master sets up the WEIGHTS_ array which will be broadcast to the
-> C FG slaves as WEIGHTS array.
-> weights_(1)=wsc
-> weights_(2)=wscp
-> weights_(3)=welec
-> weights_(4)=wcorr
-> weights_(5)=wcorr5
-> weights_(6)=wcorr6
-> weights_(7)=wel_loc
-> weights_(8)=wturn3
-> weights_(9)=wturn4
-> weights_(10)=wturn6
-> weights_(11)=wang
-> weights_(12)=wscloc
-> weights_(13)=wtor
-> weights_(14)=wtor_d
-> weights_(15)=wstrain
-> weights_(16)=wvdwpp
-> weights_(17)=wbond
-> weights_(18)=scal14
-> weights_(21)=wsccor
-> C FG Master broadcasts the WEIGHTS_ array
-> call MPI_Bcast(weights_(1),n_ene,
-> & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
-> else
-> C FG slaves receive the WEIGHTS array
-> call MPI_Bcast(weights(1),n_ene,
-> & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
-> wsc=weights(1)
-> wscp=weights(2)
-> welec=weights(3)
-> wcorr=weights(4)
-> wcorr5=weights(5)
-> wcorr6=weights(6)
-> wel_loc=weights(7)
-> wturn3=weights(8)
-> wturn4=weights(9)
-> wturn6=weights(10)
-> wang=weights(11)
-> wscloc=weights(12)
-> wtor=weights(13)
-> wtor_d=weights(14)
-> wstrain=weights(15)
-> wvdwpp=weights(16)
-> wbond=weights(17)
-> scal14=weights(18)
-> wsccor=weights(21)
-> endif
-> time_Bcast=time_Bcast+MPI_Wtime()-time00
-> time_Bcastw=time_Bcastw+MPI_Wtime()-time00
-> c call chainbuild_cart
-> endif
-> c print *,'Processor',myrank,' calling etotal ipot=',ipot
-> c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
-> #else
-> c if (modecalc.eq.12.or.modecalc.eq.14) then
-> c call int_from_cart1(.false.)
-> c endif
-> #endif
-> #ifdef TIMING
-> time00=MPI_Wtime()
-> #endif
-> C
-31c101
-< goto (101,102,103,104,105) ipot
----
-> goto (101,102,103,104,105,106) ipot
-33c103
-< 101 call elj(evdw,evdw_t)
----
-> 101 call elj(evdw)
-35c105
-< goto 106
----
-> goto 107
-37,38c107,108
-< 102 call eljk(evdw,evdw_t)
-< goto 106
----
-> 102 call eljk(evdw)
-> goto 107
-40,41c110,111
-< 103 call ebp(evdw,evdw_t)
-< goto 106
----
-> 103 call ebp(evdw)
-> goto 107
-43,44c113,114
-< 104 call egb(evdw,evdw_t)
-< goto 106
----
-> 104 call egb(evdw)
-> goto 107
-46c116,119
-< 105 call egbv(evdw,evdw_t)
----
-> 105 call egbv(evdw)
-> goto 107
-> C Soft-sphere potential
-> 106 call e_softsphere(evdw)
-50c123,158
-< 106 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
----
-> 107 continue
-> c print *,"Processor",myrank," computed USCSC"
-> #ifdef TIMING
-> time01=MPI_Wtime()
-> #endif
-> call vec_and_deriv
-> #ifdef TIMING
-> time_vec=time_vec+MPI_Wtime()-time01
-> #endif
-> c print *,"Processor",myrank," left VEC_AND_DERIV"
-> if (ipot.lt.6) then
-> #ifdef SPLITELE
-> if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
-> & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
-> & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
-> & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
-> #else
-> if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
-> & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
-> & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
-> & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
-> #endif
-> call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
-> else
-> ees=0.0d0
-> evdw1=0.0d0
-> eel_loc=0.0d0
-> eello_turn3=0.0d0
-> eello_turn4=0.0d0
-> endif
-> else
-> c write (iout,*) "Soft-spheer ELEC potential"
-> call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
-> & eello_turn4)
-> endif
-> c print *,"Processor",myrank," computed UELEC"
-55c163,173
-< call escp(evdw2,evdw2_14)
----
-> if (ipot.lt.6) then
-> if(wscp.gt.0d0) then
-> call escp(evdw2,evdw2_14)
-> else
-> evdw2=0
-> evdw2_14=0
-> endif
-> else
-> c write (iout,*) "Soft-sphere SCP potential"
-> call escp_soft_sphere(evdw2,evdw2_14)
-> endif
-60d177
-< c write (iout,*) "estr",estr
-70,71c187,192
-< call ebend(ebe)
-< cd print *,'Bend energy finished.'
----
-> if (wang.gt.0d0) then
-> call ebend(ebe)
-> else
-> ebe=0
-> endif
-> c print *,"Processor",myrank," computed UB"
-76c197
-< cd print *,'SCLOC energy finished.'
----
-> c print *,"Processor",myrank," computed USC"
-81c202,208
-< call etor(etors,edihcnstr,fact(1))
----
-> if (wtor.gt.0) then
-> call etor(etors,edihcnstr)
-> else
-> etors=0
-> edihcnstr=0
-> endif
-> c print *,"Processor",myrank," computed Utor"
-85c212,217
-< call etor_d(etors_d,fact(2))
----
-> if (wtor_d.gt.0) then
-> call etor_d(etors_d)
-> else
-> etors_d=0
-> endif
-> c print *,"Processor",myrank," computed Utord"
-89c221,226
-< call eback_sc_corr(esccor)
----
-> if (wsccor.gt.0.0d0) then
-> call eback_sc_corr(esccor)
-> else
-> esccor=0.0d0
-> endif
-> c print *,"Processor",myrank," computed Usccorr"
-95,97c232,233
-< if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
-< & .or. wturn6.gt.0.0d0) then
-< c print *,"calling multibody_eello"
----
-> if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
-> & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
-99,100c235,241
-< c write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
-< c print *,ecorr,ecorr5,ecorr6,eturn6
----
-> cd write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
-> cd &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
-> else
-> ecorr=0.0d0
-> ecorr5=0.0d0
-> ecorr6=0.0d0
-> eturn6=0.0d0
-102c243
-< if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
----
-> if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
-103a245
-> cd write (iout,*) "multibody_hb ecorr",ecorr
-105,123c247,259
-< c write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
-< #ifdef SPLITELE
-< etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
-< & +wvdwpp*evdw1
-< & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
-< & +wstrain*ehpb+nss*ebr+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
-< & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
-< & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
-< & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
-< & +wbond*estr+wsccor*fact(1)*esccor
-< #else
-< etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
-< & +welec*fact(1)*(ees+evdw1)
-< & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
-< & +wstrain*ehpb+nss*ebr+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
-< & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
-< & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
-< & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
-< & +wbond*estr+wsccor*fact(1)*esccor
----
-> c print *,"Processor",myrank," computed Ucorr"
-> C
-> C If performing constraint dynamics, call the constraint energy
-> C after the equilibration time
-> if(usampl.and.totT.gt.eq_time) then
-> call EconstrQ
-> call Econstr_back
-> else
-> Uconst=0.0d0
-> Uconst_back=0.0d0
-> endif
-> #ifdef TIMING
-> time_enecalc=time_enecalc+MPI_Wtime()-time00
-125c261,267
-< energia(0)=etot
----
-> c print *,"Processor",myrank," computed Uconstr"
-> #ifdef TIMING
-> time00=MPI_Wtime()
-> #endif
-> c
-> C Sum the energies
-> C
-129c271
-< energia(17)=evdw2_14
----
-> energia(18)=evdw2_14
-132c274
-< energia(17)=0.0d0
----
-> energia(18)=0.0d0
-153,156c295,402
-< energia(18)=estr
-< energia(19)=esccor
-< energia(20)=edihcnstr
-< energia(21)=evdw_t
----
-> energia(19)=edihcnstr
-> energia(17)=estr
-> energia(20)=Uconst+Uconst_back
-> energia(21)=esccor
-> c print *," Processor",myrank," calls SUM_ENERGY"
-> call sum_energy(energia,.true.)
-> c print *," Processor",myrank," left SUM_ENERGY"
-> #ifdef TIMING
-> time_sumene=time_sumene+MPI_Wtime()-time00
-> #endif
-> return
-> end
-> c-------------------------------------------------------------------------------
-> subroutine sum_energy(energia,reduce)
-> implicit real*8 (a-h,o-z)
-> include 'DIMENSIONS'
-> #ifndef ISNAN
-> external proc_proc
-> #ifdef WINPGI
-> cMS$ATTRIBUTES C :: proc_proc
-> #endif
-> #endif
-> #ifdef MPI
-> include "mpif.h"
-> #endif
-> include 'COMMON.SETUP'
-> include 'COMMON.IOUNITS'
-> double precision energia(0:n_ene),enebuff(0:n_ene+1)
-> include 'COMMON.FFIELD'
-> include 'COMMON.DERIV'
-> include 'COMMON.INTERACT'
-> include 'COMMON.SBRIDGE'
-> include 'COMMON.CHAIN'
-> include 'COMMON.VAR'
-> include 'COMMON.CONTROL'
-> include 'COMMON.TIME1'
-> logical reduce
-> #ifdef MPI
-> if (nfgtasks.gt.1 .and. reduce) then
-> #ifdef DEBUG
-> write (iout,*) "energies before REDUCE"
-> call enerprint(energia)
-> call flush(iout)
-> #endif
-> do i=0,n_ene
-> enebuff(i)=energia(i)
-> enddo
-> time00=MPI_Wtime()
-> call MPI_Barrier(FG_COMM,IERR)
-> time_barrier_e=time_barrier_e+MPI_Wtime()-time00
-> time00=MPI_Wtime()
-> call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
-> & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
-> #ifdef DEBUG
-> write (iout,*) "energies after REDUCE"
-> call enerprint(energia)
-> call flush(iout)
-> #endif
-> time_Reduce=time_Reduce+MPI_Wtime()-time00
-> endif
-> if (fg_rank.eq.0) then
-> #endif
-> evdw=energia(1)
-> #ifdef SCP14
-> evdw2=energia(2)+energia(18)
-> evdw2_14=energia(18)
-> #else
-> evdw2=energia(2)
-> #endif
-> #ifdef SPLITELE
-> ees=energia(3)
-> evdw1=energia(16)
-> #else
-> ees=energia(3)
-> evdw1=0.0d0
-> #endif
-> ecorr=energia(4)
-> ecorr5=energia(5)
-> ecorr6=energia(6)
-> eel_loc=energia(7)
-> eello_turn3=energia(8)
-> eello_turn4=energia(9)
-> eturn6=energia(10)
-> ebe=energia(11)
-> escloc=energia(12)
-> etors=energia(13)
-> etors_d=energia(14)
-> ehpb=energia(15)
-> edihcnstr=energia(19)
-> estr=energia(17)
-> Uconst=energia(20)
-> esccor=energia(21)
-> #ifdef SPLITELE
-> etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
-> & +wang*ebe+wtor*etors+wscloc*escloc
-> & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
-> & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
-> & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
-> & +wbond*estr+Uconst+wsccor*esccor
-> #else
-> etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
-> & +wang*ebe+wtor*etors+wscloc*escloc
-> & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
-> & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
-> & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
-> & +wbond*estr+Uconst+wsccor*esccor
-> #endif
-> energia(0)=etot
-173,174c419,464
-< #ifdef MPL
-< c endif
----
-> #ifdef MPI
-> endif
-> #endif
-> return
-> end
-> c-------------------------------------------------------------------------------
-> subroutine sum_gradient
-> implicit real*8 (a-h,o-z)
-> include 'DIMENSIONS'
-> #ifndef ISNAN
-> external proc_proc
-> #ifdef WINPGI
-> cMS$ATTRIBUTES C :: proc_proc
-> #endif
-> #endif
-> #ifdef MPI
-> include 'mpif.h'
-> double precision gradbufc(3,maxres),gradbufx(3,maxres),
-> & glocbuf(4*maxres),gradbufc_sum(3,maxres)
-> #endif
-> include 'COMMON.SETUP'
-> include 'COMMON.IOUNITS'
-> include 'COMMON.FFIELD'
-> include 'COMMON.DERIV'
-> include 'COMMON.INTERACT'
-> include 'COMMON.SBRIDGE'
-> include 'COMMON.CHAIN'
-> include 'COMMON.VAR'
-> include 'COMMON.CONTROL'
-> include 'COMMON.TIME1'
-> include 'COMMON.MAXGRAD'
-> #ifdef TIMING
-> time01=MPI_Wtime()
-> #endif
-> #ifdef DEBUG
-> write (iout,*) "sum_gradient gvdwc, gvdwx"
-> do i=1,nres
-> write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
-> & i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
-> enddo
-> call flush(iout)
-> #endif
-> #ifdef MPI
-> C FG slaves call the following matching MPI_Bcast in ERGASTULUM
-> if (nfgtasks.gt.1 .and. fg_rank.eq.0)
-> & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
-176d465
-< if (calc_grad) then
-178c467,468
-< C Sum up the components of the Cartesian gradient.
----
-> C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
-> C in virtual-bond-vector coordinates
-179a470,488
-> #ifdef DEBUG
-> c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
-> c do i=1,nres-1
-> c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
-> c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
-> c enddo
-> c write (iout,*) "gel_loc_tur3 gel_loc_turn4"
-> c do i=1,nres-1
-> c write (iout,'(i5,3f10.5,2x,f10.5)')
-> c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
-> c enddo
-> write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
-> do i=1,nres
-> write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
-> & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
-> & g_corr5_loc(i)
-> enddo
-> call flush(iout)
-> #endif
-183,198c492,500
-< gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
-< & welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
-< & wbond*gradb(j,i)+
-< & wstrain*ghpbc(j,i)+
-< & wcorr*fact(3)*gradcorr(j,i)+
-< & wel_loc*fact(2)*gel_loc(j,i)+
-< & wturn3*fact(2)*gcorr3_turn(j,i)+
-< & wturn4*fact(3)*gcorr4_turn(j,i)+
-< & wcorr5*fact(4)*gradcorr5(j,i)+
-< & wcorr6*fact(5)*gradcorr6(j,i)+
-< & wturn6*fact(5)*gcorr6_turn(j,i)+
-< & wsccor*fact(2)*gsccorc(j,i)
-< gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
-< & wbond*gradbx(j,i)+
-< & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
-< & wsccor*fact(2)*gsccorx(j,i)
----
-> gradbufc(j,i)=wsc*gvdwc(j,i)+
-> & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
-> & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
-> & wel_loc*gel_loc_long(j,i)+
-> & wcorr*gradcorr_long(j,i)+
-> & wcorr5*gradcorr5_long(j,i)+
-> & wcorr6*gradcorr6_long(j,i)+
-> & wturn6*gcorr6_turn_long(j,i)+
-> & wstrain*ghpbc(j,i)
-199a502
-> enddo
-203,204c506,508
-< gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
-< & welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
----
-> gradbufc(j,i)=wsc*gvdwc(j,i)+
-> & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
-> & welec*gelc_long(j,i)+
-206,213c510,670
-< & wcorr*fact(3)*gradcorr(j,i)+
-< & wel_loc*fact(2)*gel_loc(j,i)+
-< & wturn3*fact(2)*gcorr3_turn(j,i)+
-< & wturn4*fact(3)*gcorr4_turn(j,i)+
-< & wcorr5*fact(4)*gradcorr5(j,i)+
-< & wcorr6*fact(5)*gradcorr6(j,i)+
-< & wturn6*fact(5)*gcorr6_turn(j,i)+
-< & wsccor*fact(2)*gsccorc(j,i)
----
-> & wel_loc*gel_loc_long(j,i)+
-> & wcorr*gradcorr_long(j,i)+
-> & wcorr5*gradcorr5_long(j,i)+
-> & wcorr6*gradcorr6_long(j,i)+
-> & wturn6*gcorr6_turn_long(j,i)+
-> & wstrain*ghpbc(j,i)
-> enddo
-> enddo
-> #endif
-> #ifdef MPI
-> if (nfgtasks.gt.1) then
-> time00=MPI_Wtime()
-> #ifdef DEBUG
-> write (iout,*) "gradbufc before allreduce"
-> do i=1,nres
-> write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
-> enddo
-> call flush(iout)
-> #endif
-> do i=1,nres
-> do j=1,3
-> gradbufc_sum(j,i)=gradbufc(j,i)
-> enddo
-> enddo
-> c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
-> c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
-> c time_reduce=time_reduce+MPI_Wtime()-time00
-> #ifdef DEBUG
-> c write (iout,*) "gradbufc_sum after allreduce"
-> c do i=1,nres
-> c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
-> c enddo
-> c call flush(iout)
-> #endif
-> #ifdef TIMING
-> c time_allreduce=time_allreduce+MPI_Wtime()-time00
-> #endif
-> do i=nnt,nres
-> do k=1,3
-> gradbufc(k,i)=0.0d0
-> enddo
-> enddo
-> #ifdef DEBUG
-> write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
-> write (iout,*) (i," jgrad_start",jgrad_start(i),
-> & " jgrad_end ",jgrad_end(i),
-> & i=igrad_start,igrad_end)
-> #endif
-> c
-> c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
-> c do not parallelize this part.
-> c
-> c do i=igrad_start,igrad_end
-> c do j=jgrad_start(i),jgrad_end(i)
-> c do k=1,3
-> c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
-> c enddo
-> c enddo
-> c enddo
-> do j=1,3
-> gradbufc(j,nres-1)=gradbufc_sum(j,nres)
-> enddo
-> do i=nres-2,nnt,-1
-> do j=1,3
-> gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
-> enddo
-> enddo
-> #ifdef DEBUG
-> write (iout,*) "gradbufc after summing"
-> do i=1,nres
-> write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
-> enddo
-> call flush(iout)
-> #endif
-> else
-> #endif
-> #ifdef DEBUG
-> write (iout,*) "gradbufc"
-> do i=1,nres
-> write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
-> enddo
-> call flush(iout)
-> #endif
-> do i=1,nres
-> do j=1,3
-> gradbufc_sum(j,i)=gradbufc(j,i)
-> gradbufc(j,i)=0.0d0
-> enddo
-> enddo
-> do j=1,3
-> gradbufc(j,nres-1)=gradbufc_sum(j,nres)
-> enddo
-> do i=nres-2,nnt,-1
-> do j=1,3
-> gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
-> enddo
-> enddo
-> c do i=nnt,nres-1
-> c do k=1,3
-> c gradbufc(k,i)=0.0d0
-> c enddo
-> c do j=i+1,nres
-> c do k=1,3
-> c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
-> c enddo
-> c enddo
-> c enddo
-> #ifdef DEBUG
-> write (iout,*) "gradbufc after summing"
-> do i=1,nres
-> write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
-> enddo
-> call flush(iout)
-> #endif
-> #ifdef MPI
-> endif
-> #endif
-> do k=1,3
-> gradbufc(k,nres)=0.0d0
-> enddo
-> do i=1,nct
-> do j=1,3
-> #ifdef SPLITELE
-> gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
-> & wel_loc*gel_loc(j,i)+
-> & 0.5d0*(wscp*gvdwc_scpp(j,i)+
-> & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
-> & wel_loc*gel_loc_long(j,i)+
-> & wcorr*gradcorr_long(j,i)+
-> & wcorr5*gradcorr5_long(j,i)+
-> & wcorr6*gradcorr6_long(j,i)+
-> & wturn6*gcorr6_turn_long(j,i))+
-> & wbond*gradb(j,i)+
-> & wcorr*gradcorr(j,i)+
-> & wturn3*gcorr3_turn(j,i)+
-> & wturn4*gcorr4_turn(j,i)+
-> & wcorr5*gradcorr5(j,i)+
-> & wcorr6*gradcorr6(j,i)+
-> & wturn6*gcorr6_turn(j,i)+
-> & wsccor*gsccorc(j,i)
-> & +wscloc*gscloc(j,i)
-> #else
-> gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
-> & wel_loc*gel_loc(j,i)+
-> & 0.5d0*(wscp*gvdwc_scpp(j,i)+
-> & welec*gelc_long(j,i)
-> & wel_loc*gel_loc_long(j,i)+
-> & wcorr*gcorr_long(j,i)+
-> & wcorr5*gradcorr5_long(j,i)+
-> & wcorr6*gradcorr6_long(j,i)+
-> & wturn6*gcorr6_turn_long(j,i))+
-> & wbond*gradb(j,i)+
-> & wcorr*gradcorr(j,i)+
-> & wturn3*gcorr3_turn(j,i)+
-> & wturn4*gcorr4_turn(j,i)+
-> & wcorr5*gradcorr5(j,i)+
-> & wcorr6*gradcorr6(j,i)+
-> & wturn6*gcorr6_turn(j,i)+
-> & wsccor*gsccorc(j,i)
-> & +wscloc*gscloc(j,i)
-> #endif
-217c674,675
-< & wsccor*fact(1)*gsccorx(j,i)
----
-> & wsccor*gsccorx(j,i)
-> & +wscloc*gsclocx(j,i)
-219c677,681
-< #endif
----
-> enddo
-> #ifdef DEBUG
-> write (iout,*) "gloc before adding corr"
-> do i=1,4*nres
-> write (iout,*) i,gloc(i,icg)
-221,222c683
-<
-<
----
-> #endif
-224,231c685,697
-< gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
-< & +wcorr5*fact(4)*g_corr5_loc(i)
-< & +wcorr6*fact(5)*g_corr6_loc(i)
-< & +wturn4*fact(3)*gel_loc_turn4(i)
-< & +wturn3*fact(2)*gel_loc_turn3(i)
-< & +wturn6*fact(5)*gel_loc_turn6(i)
-< & +wel_loc*fact(2)*gel_loc_loc(i)
-< & +wsccor*fact(1)*gsccor_loc(i)
----
-> gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
-> & +wcorr5*g_corr5_loc(i)
-> & +wcorr6*g_corr6_loc(i)
-> & +wturn4*gel_loc_turn4(i)
-> & +wturn3*gel_loc_turn3(i)
-> & +wturn6*gel_loc_turn6(i)
-> & +wel_loc*gel_loc_loc(i)
-> & +wsccor*gsccor_loc(i)
-> enddo
-> #ifdef DEBUG
-> write (iout,*) "gloc after adding corr"
-> do i=1,4*nres
-> write (iout,*) i,gloc(i,icg)
-232a699,727
-> #endif
-> #ifdef MPI
-> if (nfgtasks.gt.1) then
-> do j=1,3
-> do i=1,nres
-> gradbufc(j,i)=gradc(j,i,icg)
-> gradbufx(j,i)=gradx(j,i,icg)
-> enddo
-> enddo
-> do i=1,4*nres
-> glocbuf(i)=gloc(i,icg)
-> enddo
-> time00=MPI_Wtime()
-> call MPI_Barrier(FG_COMM,IERR)
-> time_barrier_g=time_barrier_g+MPI_Wtime()-time00
-> time00=MPI_Wtime()
-> call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
-> & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
-> call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
-> & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
-> call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
-> & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
-> time_reduce=time_reduce+MPI_Wtime()-time00
-> #ifdef DEBUG
-> write (iout,*) "gloc after reduce"
-> do i=1,4*nres
-> write (iout,*) i,gloc(i,icg)
-> enddo
-> #endif
-233a729,897
-> #endif
-> if (gnorm_check) then
-> c
-> c Compute the maximum elements of the gradient
-> c
-> gvdwc_max=0.0d0
-> gvdwc_scp_max=0.0d0
-> gelc_max=0.0d0
-> gvdwpp_max=0.0d0
-> gradb_max=0.0d0
-> ghpbc_max=0.0d0
-> gradcorr_max=0.0d0
-> gel_loc_max=0.0d0
-> gcorr3_turn_max=0.0d0
-> gcorr4_turn_max=0.0d0
-> gradcorr5_max=0.0d0
-> gradcorr6_max=0.0d0
-> gcorr6_turn_max=0.0d0
-> gsccorc_max=0.0d0
-> gscloc_max=0.0d0
-> gvdwx_max=0.0d0
-> gradx_scp_max=0.0d0
-> ghpbx_max=0.0d0
-> gradxorr_max=0.0d0
-> gsccorx_max=0.0d0
-> gsclocx_max=0.0d0
-> do i=1,nct
-> gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
-> if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
-> gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
-> if (gvdwc_scp_norm.gt.gvdwc_scp_max)
-> & gvdwc_scp_max=gvdwc_scp_norm
-> gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
-> if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
-> gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
-> if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
-> gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
-> if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
-> ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
-> if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
-> gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
-> if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
-> gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
-> if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
-> gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
-> & gcorr3_turn(1,i)))
-> if (gcorr3_turn_norm.gt.gcorr3_turn_max)
-> & gcorr3_turn_max=gcorr3_turn_norm
-> gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
-> & gcorr4_turn(1,i)))
-> if (gcorr4_turn_norm.gt.gcorr4_turn_max)
-> & gcorr4_turn_max=gcorr4_turn_norm
-> gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
-> if (gradcorr5_norm.gt.gradcorr5_max)
-> & gradcorr5_max=gradcorr5_norm
-> gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
-> if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
-> gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
-> & gcorr6_turn(1,i)))
-> if (gcorr6_turn_norm.gt.gcorr6_turn_max)
-> & gcorr6_turn_max=gcorr6_turn_norm
-> gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
-> if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
-> gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
-> if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
-> gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
-> if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
-> gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
-> if (gradx_scp_norm.gt.gradx_scp_max)
-> & gradx_scp_max=gradx_scp_norm
-> ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
-> if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
-> gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
-> if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
-> gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
-> if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
-> gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
-> if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
-> enddo
-> if (gradout) then
-> #ifdef AIX
-> open(istat,file=statname,position="append")
-> #else
-> open(istat,file=statname,access="append")
-> #endif
-> write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
-> & gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
-> & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
-> & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
-> & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
-> & gsccorx_max,gsclocx_max
-> close(istat)
-> if (gvdwc_max.gt.1.0d4) then
-> write (iout,*) "gvdwc gvdwx gradb gradbx"
-> do i=nnt,nct
-> write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
-> & gradb(j,i),gradbx(j,i),j=1,3)
-> enddo
-> call pdbout(0.0d0,'cipiszcze',iout)
-> call flush(iout)
-> endif
-> endif
-> endif
-> #ifdef DEBUG
-> write (iout,*) "gradc gradx gloc"
-> do i=1,nres
-> write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
-> & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
-> enddo
-> #endif
-> #ifdef TIMING
-> time_sumgradient=time_sumgradient+MPI_Wtime()-time01
-> #endif
-> return
-> end
-> c-------------------------------------------------------------------------------
-> subroutine rescale_weights(t_bath)
-> implicit real*8 (a-h,o-z)
-> include 'DIMENSIONS'
-> include 'COMMON.IOUNITS'
-> include 'COMMON.FFIELD'
-> include 'COMMON.SBRIDGE'
-> double precision kfac /2.4d0/
-> double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
-> c facT=temp0/t_bath
-> c facT=2*temp0/(t_bath+temp0)
-> if (rescale_mode.eq.0) then
-> facT=1.0d0
-> facT2=1.0d0
-> facT3=1.0d0
-> facT4=1.0d0
-> facT5=1.0d0
-> else if (rescale_mode.eq.1) then
-> facT=kfac/(kfac-1.0d0+t_bath/temp0)
-> facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
-> facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
-> facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
-> facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
-> else if (rescale_mode.eq.2) then
-> x=t_bath/temp0
-> x2=x*x
-> x3=x2*x
-> x4=x3*x
-> x5=x4*x
-> facT=licznik/dlog(dexp(x)+dexp(-x))
-> facT2=licznik/dlog(dexp(x2)+dexp(-x2))
-> facT3=licznik/dlog(dexp(x3)+dexp(-x3))
-> facT4=licznik/dlog(dexp(x4)+dexp(-x4))
-> facT5=licznik/dlog(dexp(x5)+dexp(-x5))
-> else
-> write (iout,*) "Wrong RESCALE_MODE",rescale_mode
-> write (*,*) "Wrong RESCALE_MODE",rescale_mode
-> #ifdef MPI
-> call MPI_Finalize(MPI_COMM_WORLD,IERROR)
-> #endif
-> stop 555
-> endif
-> welec=weights(3)*fact
-> wcorr=weights(4)*fact3
-> wcorr5=weights(5)*fact4
-> wcorr6=weights(6)*fact5
-> wel_loc=weights(7)*fact2
-> wturn3=weights(8)*fact2
-> wturn4=weights(9)*fact3
-> wturn6=weights(10)*fact5
-> wtor=weights(13)*fact
-> wtor_d=weights(14)*fact2
-> wsccor=weights(21)*fact
->
-237c901
-< subroutine enerprint(energia,fact)
----
-> subroutine enerprint(energia)
-240d903
-< include 'DIMENSIONS.ZSCOPT'
-244c907,908
-< double precision energia(0:max_ene),fact(6)
----
-> include 'COMMON.MD'
-> double precision energia(0:n_ene)
-246c910,911
-< evdw=energia(1)+fact(6)*energia(21)
----
-> evdw=energia(1)
-> evdw2=energia(2)
-248c913
-< evdw2=energia(2)+energia(17)
----
-> evdw2=energia(2)+energia(18)
-268,270c933,936
-< esccor=energia(19)
-< edihcnstr=energia(20)
-< estr=energia(18)
----
-> edihcnstr=energia(19)
-> estr=energia(17)
-> Uconst=energia(20)
-> esccor=energia(21)
-272,279c938,945
-< write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
-< & wvdwpp,
-< & estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
-< & etors_d,wtor_d*fact(2),ehpb,wstrain,
-< & ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
-< & eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
-< & eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
-< & esccor,wsccor*fact(1),edihcnstr,ebr*nss,etot
----
-> write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
-> & estr,wbond,ebe,wang,
-> & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
-> & ecorr,wcorr,
-> & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
-> & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
-> & edihcnstr,ebr*nss,
-> & Uconst,etot
-283c949
-< & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
----
-> & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
-301c967,968
-< & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
----
-> & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
-> & 'UCONST= ',1pE16.6,' (Constraint energy)'/
-304,310c971,977
-< write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
-< & ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
-< & ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
-< & ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
-< & eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
-< & eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
-< & edihcnstr,ebr*nss,etot
----
-> write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
-> & estr,wbond,ebe,wang,
-> & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
-> & ecorr,wcorr,
-> & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
-> & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
-> & ebr*nss,Uconst,etot
-331c998,999
-< & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
----
-> & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
-> & 'UCONST=',1pE16.6,' (Constraint energy)'/
-337c1005
-< subroutine elj(evdw,evdw_t)
----
-> subroutine elj(evdw)
-344,345d1011
-< include 'DIMENSIONS.ZSCOPT'
-< include "DIMENSIONS.COMPAR"
-354d1019
-< include 'COMMON.ENEPS'
-360,367c1025
-< integer icant
-< external icant
-< cd print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
-< do i=1,210
-< do j=1,2
-< eneps_temp(j,i)=0.0d0
-< enddo
-< enddo
----
-> c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
-369d1026
-< evdw_t=0.0d0
-400,402d1056
-< ij=icant(itypi,itypj)
-< eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
-< eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
-409,414c1063
-< if (bb(itypi,itypj).gt.0.0d0) then
-< evdw=evdw+evdwij
-< else
-< evdw_t=evdw_t+evdwij
-< endif
-< if (calc_grad) then
----
-> evdw=evdw+evdwij
-424a1074,1075
-> gvdwc(k,i)=gvdwc(k,i)-gg(k)
-> gvdwc(k,j)=gvdwc(k,j)+gg(k)
-426,431c1077,1081
-< do k=i,j-1
-< do l=1,3
-< gvdwc(l,k)=gvdwc(l,k)+gg(l)
-< enddo
-< enddo
-< endif
----
-> cgrad do k=i,j-1
-> cgrad do l=1,3
-> cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
-> cgrad enddo
-> cgrad enddo
-493d1142
-< if (calc_grad) then
-500d1148
-< endif
-513c1161
-< subroutine eljk(evdw,evdw_t)
----
-> subroutine eljk(evdw)
-520,521d1167
-< include 'DIMENSIONS.ZSCOPT'
-< include "DIMENSIONS.COMPAR"
-528d1173
-< include 'COMMON.ENEPS'
-533,534d1177
-< integer icant
-< external icant
-536,540d1178
-< do i=1,210
-< do j=1,2
-< eneps_temp(j,i)=0.0d0
-< enddo
-< enddo
-542d1179
-< evdw_t=0.0d0
-570,573d1206
-< ij=icant(itypi,itypj)
-< eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
-< & /dabs(eps(itypi,itypj))
-< eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
-581,586c1214
-< if (bb(itypi,itypj).gt.0.0d0) then
-< evdw=evdw+evdwij
-< else
-< evdw_t=evdw_t+evdwij
-< endif
-< if (calc_grad) then
----
-> evdw=evdw+evdwij
-596a1225,1226
-> gvdwc(k,i)=gvdwc(k,i)-gg(k)
-> gvdwc(k,j)=gvdwc(k,j)+gg(k)
-598,603c1228,1232
-< do k=i,j-1
-< do l=1,3
-< gvdwc(l,k)=gvdwc(l,k)+gg(l)
-< enddo
-< enddo
-< endif
----
-> cgrad do k=i,j-1
-> cgrad do l=1,3
-> cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
-> cgrad enddo
-> cgrad enddo
-607d1235
-< if (calc_grad) then
-614d1241
-< endif
-618c1245
-< subroutine ebp(evdw,evdw_t)
----
-> subroutine ebp(evdw)
-625,626d1251
-< include 'DIMENSIONS.ZSCOPT'
-< include "DIMENSIONS.COMPAR"
-634d1258
-< include 'COMMON.ENEPS'
-640,646d1263
-< integer icant
-< external icant
-< do i=1,210
-< do j=1,2
-< eneps_temp(j,i)=0.0d0
-< enddo
-< enddo
-648d1264
-< evdw_t=0.0d0
-649a1266
-> evdw=0.0D0
-665a1283
-> c dsci_inv=dsc_inv(itypi)
-674a1293
-> c dscj_inv=dsc_inv(itypj)
-719,729c1338
-< ij=icant(itypi,itypj)
-< aux=eps1*eps2rt**2*eps3rt**2
-< eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
-< & /dabs(eps(itypi,itypj))
-< eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
-< if (bb(itypi,itypj).gt.0.0d0) then
-< evdw=evdw+evdwij
-< else
-< evdw_t=evdw_t+evdwij
-< endif
-< if (calc_grad) then
----
-> evdw=evdw+evdwij
-752d1360
-< endif
-760c1368
-< subroutine egb(evdw,evdw_t)
----
-> subroutine egb(evdw)
-767,768d1374
-< include 'DIMENSIONS.ZSCOPT'
-< include "DIMENSIONS.COMPAR"
-776d1381
-< include 'COMMON.ENEPS'
-778a1384
-> include 'COMMON.CONTROL'
-780,787c1386,1387
-< common /srutu/icall
-< integer icant
-< external icant
-< do i=1,210
-< do j=1,2
-< eneps_temp(j,i)=0.0d0
-< enddo
-< enddo
----
-> evdw=0.0D0
-> ccccc energy_dec=.false.
-790d1389
-< evdw_t=0.0d0
-792c1391
-< c if (icall.gt.0) lprn=.true.
----
-> c if (icall.eq.0) lprn=.false.
-803a1403
-> c dsci_inv=dsc_inv(itypi)
-804a1405,1406
-> c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
-> c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
-812a1415
-> c dscj_inv=dsc_inv(itypj)
-813a1417,1419
-> c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
-> c & 1.0d0/vbld(j+nres)
-> c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
-840c1446,1448
-< c write (iout,*) i,j,xj,yj,zj
----
-> c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
-> c write (iout,*) "j",j," dc_norm",
-> c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
-848a1457,1458
-> c for diagnostics; uncomment
-> c rij_shift=1.2*sig0ij
-851a1462,1464
-> cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
-> cd & restyp(itypi),i,restyp(itypj),j,
-> cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
-862a1476,1477
-> c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
-> c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
-864,876c1479
-< if (bb(itypi,itypj).gt.0) then
-< evdw=evdw+evdwij
-< else
-< evdw_t=evdw_t+evdwij
-< endif
-< ij=icant(itypi,itypj)
-< aux=eps1*eps2rt**2*eps3rt**2
-< eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
-< & /dabs(eps(itypi,itypj))
-< eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
-< c write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
-< c & " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
-< c & aux*e2/eps(itypi,itypj)
----
-> evdw=evdw+evdwij
-887c1490,1493
-< if (calc_grad) then
----
->
-> if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
-> & 'evdw',i,j,evdwij
->
-892a1499
-> c fac=0.0d0
-899d1505
-< endif
-902a1509,1510
-> c write (iout,*) "Number of loop steps in EGB:",ind
-> cccc energy_dec=.false.
-906c1514
-< subroutine egbv(evdw,evdw_t)
----
-> subroutine egbv(evdw)
-913,914d1520
-< include 'DIMENSIONS.ZSCOPT'
-< include "DIMENSIONS.COMPAR"
-922d1527
-< include 'COMMON.ENEPS'
-927,933d1531
-< integer icant
-< external icant
-< do i=1,210
-< do j=1,2
-< eneps_temp(j,i)=0.0d0
-< enddo
-< enddo
-935d1532
-< evdw_t=0.0d0
-939c1536
-< c if (icall.gt.0) lprn=.true.
----
-> c if (icall.eq.0) lprn=.true.
-950a1548
-> c dsci_inv=dsc_inv(itypi)
-959a1558
-> c dscj_inv=dsc_inv(itypj)
-1013,1016c1612,1622
-< if (bb(itypi,itypj).gt.0.0d0) then
-< evdw=evdw+evdwij+e_augm
-< else
-< evdw_t=evdw_t+evdwij+e_augm
----
-> evdw=evdw+evdwij+e_augm
-> if (lprn) then
-> sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
-> epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
-> write (iout,'(2(a3,i3,2x),17(0pf7.3))')
-> & restyp(itypi),i,restyp(itypj),j,
-> & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
-> & chi1,chi2,chip1,chip2,
-> & eps1,eps2rt**2,eps3rt**2,
-> & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
-> & evdwij+e_augm
-1018,1036d1623
-< ij=icant(itypi,itypj)
-< aux=eps1*eps2rt**2*eps3rt**2
-< eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
-< & /dabs(eps(itypi,itypj))
-< eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
-< c eneps_temp(ij)=eneps_temp(ij)
-< c & +(evdwij+e_augm)/eps(itypi,itypj)
-< c if (lprn) then
-< c sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
-< c epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
-< c write (iout,'(2(a3,i3,2x),17(0pf7.3))')
-< c & restyp(itypi),i,restyp(itypj),j,
-< c & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
-< c & chi1,chi2,chip1,chip2,
-< c & eps1,eps2rt**2,eps3rt**2,
-< c & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
-< c & evdwij+e_augm
-< c endif
-< if (calc_grad) then
-1048d1634
-< endif
-1052d1637
-< return
-1059a1645
-> include 'COMMON.IOUNITS'
-1072a1659,1663
-> c diagnostics only
-> c faceps1_inv=om12
-> c eps1=om12
-> c eps1_om12=1.0d0
-> c write (iout,*) "om12",om12," eps1",eps1
-1082a1674,1681
-> c diagnostics only
-> c sigsq=1.0d0
-> c sigsq_om1=0.0d0
-> c sigsq_om2=0.0d0
-> c sigsq_om12=0.0d0
-> c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
-> c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
-> c & " eps1",eps1
-1089a1689,1690
-> c write (iout,*) "chipom1",chipom1," chipom2",chipom2,
-> c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv
-1098a1700,1702
-> c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
-> c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
-> c & " eps2rt_om12",eps2rt_om12
-1107d1710
-< include 'DIMENSIONS.ZSCOPT'
-1110a1714
-> include 'COMMON.IOUNITS'
-1115a1720,1728
-> c diagnostics only
-> c eom1=0.0d0
-> c eom2=0.0d0
-> c eom12=evdwij*eps1_om12
-> c end diagnostics
-> c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
-> c & " sigder",sigder
-> c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
-> c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
-1122a1736
-> c write (iout,*) "gg",(gg(k),k=1,3)
-1129a1744,1747
-> c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
-> c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
-> c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
-> c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
-1134,1137c1752,1759
-< do k=i,j-1
-< do l=1,3
-< gvdwc(l,k)=gvdwc(l,k)+gg(l)
-< enddo
----
-> cgrad do k=i,j-1
-> cgrad do l=1,3
-> cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
-> cgrad enddo
-> cgrad enddo
-> do l=1,3
-> gvdwc(l,i)=gvdwc(l,i)-gg(l)
-> gvdwc(l,j)=gvdwc(l,j)+gg(l)
-1141,1142c1763,1768
-< c------------------------------------------------------------------------------
-< subroutine vec_and_deriv
----
-> C-----------------------------------------------------------------------
-> subroutine e_softsphere(evdw)
-> C
-> C This subroutine calculates the interaction energy of nonbonded side chains
-> C assuming the LJ potential of interaction.
-> C
-1145,1146c1771
-< include 'DIMENSIONS.ZSCOPT'
-< include 'COMMON.IOUNITS'
----
-> parameter (accur=1.0d-10)
-1151d1775
-< include 'COMMON.VECTORS'
-1154,1247c1778,1815
-< dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
-< C Compute the local reference systems. For reference system (i), the
-< C X-axis points from CA(i) to CA(i+1), the Y axis is in the
-< C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
-< do i=1,nres-1
-< c if (i.eq.nres-1 .or. itel(i+1).eq.0) then
-< if (i.eq.nres-1) then
-< C Case of the last full residue
-< C Compute the Z-axis
-< call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
-< costh=dcos(pi-theta(nres))
-< fac=1.0d0/dsqrt(1.0d0-costh*costh)
-< do k=1,3
-< uz(k,i)=fac*uz(k,i)
-< enddo
-< if (calc_grad) then
-< C Compute the derivatives of uz
-< uzder(1,1,1)= 0.0d0
-< uzder(2,1,1)=-dc_norm(3,i-1)
-< uzder(3,1,1)= dc_norm(2,i-1)
-< uzder(1,2,1)= dc_norm(3,i-1)
-< uzder(2,2,1)= 0.0d0
-< uzder(3,2,1)=-dc_norm(1,i-1)
-< uzder(1,3,1)=-dc_norm(2,i-1)
-< uzder(2,3,1)= dc_norm(1,i-1)
-< uzder(3,3,1)= 0.0d0
-< uzder(1,1,2)= 0.0d0
-< uzder(2,1,2)= dc_norm(3,i)
-< uzder(3,1,2)=-dc_norm(2,i)
-< uzder(1,2,2)=-dc_norm(3,i)
-< uzder(2,2,2)= 0.0d0
-< uzder(3,2,2)= dc_norm(1,i)
-< uzder(1,3,2)= dc_norm(2,i)
-< uzder(2,3,2)=-dc_norm(1,i)
-< uzder(3,3,2)= 0.0d0
-< endif
-< C Compute the Y-axis
-< facy=fac
-< do k=1,3
-< uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
-< enddo
-< if (calc_grad) then
-< C Compute the derivatives of uy
-< do j=1,3
-< do k=1,3
-< uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
-< & -dc_norm(k,i)*dc_norm(j,i-1)
-< uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
-< enddo
-< uyder(j,j,1)=uyder(j,j,1)-costh
-< uyder(j,j,2)=1.0d0+uyder(j,j,2)
-< enddo
-< do j=1,2
-< do k=1,3
-< do l=1,3
-< uygrad(l,k,j,i)=uyder(l,k,j)
-< uzgrad(l,k,j,i)=uzder(l,k,j)
-< enddo
-< enddo
-< enddo
-< call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
-< call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
-< call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
-< call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
-< endif
-< else
-< C Other residues
-< C Compute the Z-axis
-< call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
-< costh=dcos(pi-theta(i+2))
-< fac=1.0d0/dsqrt(1.0d0-costh*costh)
-< do k=1,3
-< uz(k,i)=fac*uz(k,i)
-< enddo
-< if (calc_grad) then
-< C Compute the derivatives of uz
-< uzder(1,1,1)= 0.0d0
-< uzder(2,1,1)=-dc_norm(3,i+1)
-< uzder(3,1,1)= dc_norm(2,i+1)
-< uzder(1,2,1)= dc_norm(3,i+1)
-< uzder(2,2,1)= 0.0d0
-< uzder(3,2,1)=-dc_norm(1,i+1)
-< uzder(1,3,1)=-dc_norm(2,i+1)
-< uzder(2,3,1)= dc_norm(1,i+1)
-< uzder(3,3,1)= 0.0d0
-< uzder(1,1,2)= 0.0d0
-< uzder(2,1,2)= dc_norm(3,i)
-< uzder(3,1,2)=-dc_norm(2,i)
-< uzder(1,2,2)=-dc_norm(3,i)
-< uzder(2,2,2)= 0.0d0
-< uzder(3,2,2)= dc_norm(1,i)
-< uzder(1,3,2)= dc_norm(2,i)
-< uzder(2,3,2)=-dc_norm(1,i)
-< uzder(3,3,2)= 0.0d0
----
-> include 'COMMON.TORSION'
-> include 'COMMON.SBRIDGE'
-> include 'COMMON.NAMES'
-> include 'COMMON.IOUNITS'
-> include 'COMMON.CONTACTS'
-> dimension gg(3)
-> cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
-> evdw=0.0D0
-> do i=iatsc_s,iatsc_e
-> itypi=itype(i)
-> if (itypi.eq.21) cycle
-> itypi1=itype(i+1)
-> xi=c(1,nres+i)
-> yi=c(2,nres+i)
-> zi=c(3,nres+i)
-> C
-> C Calculate SC interaction energy.
-> C
-> do iint=1,nint_gr(i)
-> cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
-> cd & 'iend=',iend(i,iint)
-> do j=istart(i,iint),iend(i,iint)
-> itypj=itype(j)
-> if (itypj.eq.21) cycle
-> xj=c(1,nres+j)-xi
-> yj=c(2,nres+j)-yi
-> zj=c(3,nres+j)-zi
-> rij=xj*xj+yj*yj+zj*zj
-> c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
-> r0ij=r0(itypi,itypj)
-> r0ijsq=r0ij*r0ij
-> c print *,i,j,r0ij,dsqrt(rij)
-> if (rij.lt.r0ijsq) then
-> evdwij=0.25d0*(rij-r0ijsq)**2
-> fac=rij-r0ijsq
-> else
-> evdwij=0.0d0
-> fac=0.0d0
-1249,1250c1817,1823
-< C Compute the Y-axis
-< facy=fac
----
-> evdw=evdw+evdwij
-> C
-> C Calculate the components of the gradient in DC and X
-> C
-> gg(1)=xj*fac
-> gg(2)=yj*fac
-> gg(3)=zj*fac
-1252,1263c1825,1828
-< uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
-< enddo
-< if (calc_grad) then
-< C Compute the derivatives of uy
-< do j=1,3
-< do k=1,3
-< uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
-< & -dc_norm(k,i)*dc_norm(j,i+1)
-< uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
-< enddo
-< uyder(j,j,1)=uyder(j,j,1)-costh
-< uyder(j,j,2)=1.0d0+uyder(j,j,2)
----
-> gvdwx(k,i)=gvdwx(k,i)-gg(k)
-> gvdwx(k,j)=gvdwx(k,j)+gg(k)
-> gvdwc(k,i)=gvdwc(k,i)-gg(k)
-> gvdwc(k,j)=gvdwc(k,j)+gg(k)
-1265,1277c1830,1898
-< do j=1,2
-< do k=1,3
-< do l=1,3
-< uygrad(l,k,j,i)=uyder(l,k,j)
-< uzgrad(l,k,j,i)=uzder(l,k,j)
-< enddo
-< enddo
-< enddo
-< call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
-< call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
-< call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
-< call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
-< endif
----
-> cgrad do k=i,j-1
-> cgrad do l=1,3
-> cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
-> cgrad enddo
-> cgrad enddo
-> enddo ! j
-> enddo ! iint
-> enddo ! i
-> return
-> end
-> C--------------------------------------------------------------------------
-> subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
-> & eello_turn4)
-> C
-> C Soft-sphere potential of p-p interaction
-> C
-> implicit real*8 (a-h,o-z)
-> include 'DIMENSIONS'
-> include 'COMMON.CONTROL'
-> include 'COMMON.IOUNITS'
-> include 'COMMON.GEO'
-> include 'COMMON.VAR'
-> include 'COMMON.LOCAL'
-> include 'COMMON.CHAIN'
-> include 'COMMON.DERIV'
-> include 'COMMON.INTERACT'
-> include 'COMMON.CONTACTS'
-> include 'COMMON.TORSION'
-> include 'COMMON.VECTORS'
-> include 'COMMON.FFIELD'
-> dimension ggg(3)
-> cd write(iout,*) 'In EELEC_soft_sphere'
-> ees=0.0D0
-> evdw1=0.0D0
-> eel_loc=0.0d0
-> eello_turn3=0.0d0
-> eello_turn4=0.0d0
-> ind=0
-> do i=iatel_s,iatel_e
-> if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
-> dxi=dc(1,i)
-> dyi=dc(2,i)
-> dzi=dc(3,i)
-> xmedi=c(1,i)+0.5d0*dxi
-> ymedi=c(2,i)+0.5d0*dyi
-> zmedi=c(3,i)+0.5d0*dzi
-> num_conti=0
-> c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
-> do j=ielstart(i),ielend(i)
-> if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle
-> ind=ind+1
-> iteli=itel(i)
-> itelj=itel(j)
-> if (j.eq.i+2 .and. itelj.eq.2) iteli=2
-> r0ij=rpp(iteli,itelj)
-> r0ijsq=r0ij*r0ij
-> dxj=dc(1,j)
-> dyj=dc(2,j)
-> dzj=dc(3,j)
-> xj=c(1,j)+0.5D0*dxj-xmedi
-> yj=c(2,j)+0.5D0*dyj-ymedi
-> zj=c(3,j)+0.5D0*dzj-zmedi
-> rij=xj*xj+yj*yj+zj*zj
-> if (rij.lt.r0ijsq) then
-> evdw1ij=0.25d0*(rij-r0ijsq)**2
-> fac=rij-r0ijsq
-> else
-> evdw1ij=0.0d0
-> fac=0.0d0
-1279,1288c1900,1906
-< enddo
-< if (calc_grad) then
-< do i=1,nres-1
-< vbld_inv_temp(1)=vbld_inv(i+1)
-< if (i.lt.nres-1) then
-< vbld_inv_temp(2)=vbld_inv(i+2)
-< else
-< vbld_inv_temp(2)=vbld_inv(i)
-< endif
-< do j=1,2
----
-> evdw1=evdw1+evdw1ij
-> C
-> C Calculate contributions to the Cartesian gradient.
-> C
-> ggg(1)=fac*xj
-> ggg(2)=fac*yj
-> ggg(3)=fac*zj
-1290,1293c1908,1909
-< do l=1,3
-< uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
-< uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
-< enddo
----
-> gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
-> gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
-1295,1297c1911,1930
-< enddo
-< enddo
-< endif
----
-> *
-> * Loop over residues i+1 thru j-1.
-> *
-> cgrad do k=i+1,j-1
-> cgrad do l=1,3
-> cgrad gelc(l,k)=gelc(l,k)+ggg(l)
-> cgrad enddo
-> cgrad enddo
-> enddo ! j
-> enddo ! i
-> cgrad do i=nnt,nct-1
-> cgrad do k=1,3
-> cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
-> cgrad enddo
-> cgrad do j=i+1,nct-1
-> cgrad do k=1,3
-> cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)
-> cgrad enddo
-> cgrad enddo
-> cgrad enddo
-1300,1301c1933,1934
-< C-----------------------------------------------------------------------------
-< subroutine vec_and_deriv_test
----
-> c------------------------------------------------------------------------------
-> subroutine vec_and_deriv
-1304c1937,1939
-< include 'DIMENSIONS.ZSCOPT'
----
-> #ifdef MPI
-> include 'mpif.h'
-> #endif
-1311c1946,1948
-< dimension uyder(3,3,2),uzder(3,3,2)
----
-> include 'COMMON.SETUP'
-> include 'COMMON.TIME1'
-> dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
-1314a1952,1954
-> #ifdef PARVEC
-> do i=ivec_start,ivec_end
-> #else
-1315a1956
-> #endif
-1322,1324d1962
-< c write (iout,*) 'fac',fac,
-< c & 1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
-< fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
-1348,1350d1985
-< do k=1,3
-< uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
-< enddo
-1352,1365d1986
-< facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
-< & (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
-< & scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
-< do k=1,3
-< c uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
-< uy(k,i)=
-< c & facy*(
-< & dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
-< & -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
-< c & )
-< enddo
-< c write (iout,*) 'facy',facy,
-< c & 1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
-< facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
-1367c1988
-< uy(k,i)=facy*uy(k,i)
----
-> uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
-1376,1381c1997,1998
-< c uyder(j,j,1)=uyder(j,j,1)-costh
-< c uyder(j,j,2)=1.0d0+uyder(j,j,2)
-< uyder(j,j,1)=uyder(j,j,1)
-< & -scalar(dc_norm(1,i),dc_norm(1,i-1))
-< uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
-< & +uyder(j,j,2)
----
-> uyder(j,j,1)=uyder(j,j,1)-costh
-> uyder(j,j,2)=1.0d0+uyder(j,j,2)
-1401d2017
-< fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
-1426,1439d2041
-< facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
-< & (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
-< & scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
-< do k=1,3
-< c uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
-< uy(k,i)=
-< c & facy*(
-< & dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
-< & -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
-< c & )
-< enddo
-< c write (iout,*) 'facy',facy,
-< c & 1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
-< facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
-1441c2043
-< uy(k,i)=facy*uy(k,i)
----
-> uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
-1450,1455c2052,2053
-< c uyder(j,j,1)=uyder(j,j,1)-costh
-< c uyder(j,j,2)=1.0d0+uyder(j,j,2)
-< uyder(j,j,1)=uyder(j,j,1)
-< & -scalar(dc_norm(1,i),dc_norm(1,i+1))
-< uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
-< & +uyder(j,j,2)
----
-> uyder(j,j,1)=uyder(j,j,1)-costh
-> uyder(j,j,2)=1.0d0+uyder(j,j,2)
-1471a2070,2075
-> vbld_inv_temp(1)=vbld_inv(i+1)
-> if (i.lt.nres-1) then
-> vbld_inv_temp(2)=vbld_inv(i+2)
-> else
-> vbld_inv_temp(2)=vbld_inv(i)
-> endif
-1475,1476c2079,2080
-< uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
-< uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
----
-> uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
-> uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
-1480a2085,2112
-> #if defined(PARVEC) && defined(MPI)
-> if (nfgtasks1.gt.1) then
-> time00=MPI_Wtime()
-> c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
-> c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
-> c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
-> call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
-> & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
-> & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
-> & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
-> & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
-> call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
-> & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
-> & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
-> time_gather=time_gather+MPI_Wtime()-time00
-> endif
-> c if (fg_rank.eq.0) then
-> c write (iout,*) "Arrays UY and UZ"
-> c do i=1,nres-1
-> c write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
-> c & (uz(k,i),k=1,3)
-> c enddo
-> c endif
-> #endif
-1487d2118
-< include 'DIMENSIONS.ZSCOPT'
-1572c2203,2208
-< include 'DIMENSIONS.ZSCOPT'
----
-> #ifdef MPI
-> include "mpif.h"
-> include "COMMON.SETUP"
-> integer IERR
-> integer status(MPI_STATUS_SIZE)
-> #endif
-1588a2225,2227
-> #ifdef PARMAT
-> do i=ivec_start+2,ivec_end+2
-> #else
-1589a2229
-> #endif
-1655a2296
-> c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
-1657,1661c2298
-< if (itype(i-2).le.ntyp) then
-< iti = itortyp(itype(i-2))
-< else
-< iti=ntortyp+1
-< endif
----
-> iti = itortyp(itype(i-2))
-1664a2302
-> c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
-1666,1670c2304
-< if (itype(i-1).le.ntyp) then
-< iti1 = itortyp(itype(i-1))
-< else
-< iti1=ntortyp+1
-< endif
----
-> iti1 = itortyp(itype(i-1))
-1678,1679c2312,2313
-< c print *,"itilde1 i iti iti1",i,iti,iti1
-< if (i .gt. iatel_s+2) then
----
-> c if (i .gt. iatel_s+2) then
-> if (i .gt. nnt+2) then
-1681a2316,2317
-> if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
-> & then
-1686a2323
-> endif
-1700d2336
-< c print *,"itilde2 i iti iti1",i,iti,iti1
-1703,1708d2338
-< call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
-< call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
-< call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
-< call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
-< call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
-< c print *,"itilde3 i iti iti1",i,iti,iti1
-1711a2342
-> c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
-1713,1717c2344
-< if (itype(i-1).le.ntyp) then
-< iti1 = itortyp(itype(i-1))
-< else
-< iti1=ntortyp+1
-< endif
----
-> iti1 = itortyp(itype(i-1))
-1723a2351,2360
-> cd write (iout,*) 'mu ',mu(:,i-2)
-> cd write (iout,*) 'mu1',mu1(:,i-2)
-> cd write (iout,*) 'mu2',mu2(:,i-2)
-> if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
-> & then
-> call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
-> call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
-> call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
-> call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
-> call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
-1734,1735c2371
-< cd write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
-< cd & ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
----
-> endif
-1738a2375,2377
-> if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
-> &then
-> c do i=max0(ivec_start,2),ivec_end
-1748a2388,2636
-> endif
-> #if defined(MPI) && defined(PARMAT)
-> #ifdef DEBUG
-> c if (fg_rank.eq.0) then
-> write (iout,*) "Arrays UG and UGDER before GATHER"
-> do i=1,nres-1
-> write (iout,'(i5,4f10.5,5x,4f10.5)') i,
-> & ((ug(l,k,i),l=1,2),k=1,2),
-> & ((ugder(l,k,i),l=1,2),k=1,2)
-> enddo
-> write (iout,*) "Arrays UG2 and UG2DER"
-> do i=1,nres-1
-> write (iout,'(i5,4f10.5,5x,4f10.5)') i,
-> & ((ug2(l,k,i),l=1,2),k=1,2),
-> & ((ug2der(l,k,i),l=1,2),k=1,2)
-> enddo
-> write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
-> do i=1,nres-1
-> write (iout,'(i5,4f10.5,5x,4f10.5)') i,
-> & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
-> & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
-> enddo
-> write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
-> do i=1,nres-1
-> write (iout,'(i5,4f10.5,5x,4f10.5)') i,
-> & costab(i),sintab(i),costab2(i),sintab2(i)
-> enddo
-> write (iout,*) "Array MUDER"
-> do i=1,nres-1
-> write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
-> enddo
-> c endif
-> #endif
-> if (nfgtasks.gt.1) then
-> time00=MPI_Wtime()
-> c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
-> c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
-> c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
-> #ifdef MATGATHER
-> call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
-> & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
-> & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
-> & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
-> & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
-> & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
-> & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
-> & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
-> & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
-> call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
-> & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
-> & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
-> call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
-> & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
-> & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
-> call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
-> & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
-> & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
-> if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
-> & then
-> call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
-> & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
-> & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
-> & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
-> & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
-> & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
-> & ivec_count(fg_rank1),
-> & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
-> & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
-> & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
-> & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
-> & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
-> & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
-> & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
-> & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
-> & ivec_count(fg_rank1),
-> & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
-> & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
-> & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
-> & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
-> & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
-> & ivec_count(fg_rank1),
-> & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
-> & ivec_count(fg_rank1),
-> & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
-> & FG_COMM1,IERR)
-> call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
-> & ivec_count(fg_rank1),
-> & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
-> & MPI_MAT2,FG_COMM1,IERR)
-> call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
-> & ivec_count(fg_rank1),
-> & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
-> & MPI_MAT2,FG_COMM1,IERR)
-> endif
-> #else
-> c Passes matrix info through the ring
-> isend=fg_rank1
-> irecv=fg_rank1-1
-> if (irecv.lt.0) irecv=nfgtasks1-1
-> iprev=irecv
-> inext=fg_rank1+1
-> if (inext.ge.nfgtasks1) inext=0
-> do i=1,nfgtasks1-1
-> c write (iout,*) "isend",isend," irecv",irecv
-> c call flush(iout)
-> lensend=lentyp(isend)
-> lenrecv=lentyp(irecv)
-> c write (iout,*) "lensend",lensend," lenrecv",lenrecv
-> c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
-> c & MPI_ROTAT1(lensend),inext,2200+isend,
-> c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
-> c & iprev,2200+irecv,FG_COMM,status,IERR)
-> c write (iout,*) "Gather ROTAT1"
-> c call flush(iout)
-> c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
-> c & MPI_ROTAT2(lensend),inext,3300+isend,
-> c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
-> c & iprev,3300+irecv,FG_COMM,status,IERR)
-> c write (iout,*) "Gather ROTAT2"
-> c call flush(iout)
-> call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
-> & MPI_ROTAT_OLD(lensend),inext,4400+isend,
-> & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
-> & iprev,4400+irecv,FG_COMM,status,IERR)
-> c write (iout,*) "Gather ROTAT_OLD"
-> c call flush(iout)
-> call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
-> & MPI_PRECOMP11(lensend),inext,5500+isend,
-> & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
-> & iprev,5500+irecv,FG_COMM,status,IERR)
-> c write (iout,*) "Gather PRECOMP11"
-> c call flush(iout)
-> call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
-> & MPI_PRECOMP12(lensend),inext,6600+isend,
-> & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
-> & iprev,6600+irecv,FG_COMM,status,IERR)
-> c write (iout,*) "Gather PRECOMP12"
-> c call flush(iout)
-> if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
-> & then
-> call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
-> & MPI_ROTAT2(lensend),inext,7700+isend,
-> & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
-> & iprev,7700+irecv,FG_COMM,status,IERR)
-> c write (iout,*) "Gather PRECOMP21"
-> c call flush(iout)
-> call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
-> & MPI_PRECOMP22(lensend),inext,8800+isend,
-> & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
-> & iprev,8800+irecv,FG_COMM,status,IERR)
-> c write (iout,*) "Gather PRECOMP22"
-> c call flush(iout)
-> call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
-> & MPI_PRECOMP23(lensend),inext,9900+isend,
-> & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
-> & MPI_PRECOMP23(lenrecv),
-> & iprev,9900+irecv,FG_COMM,status,IERR)
-> c write (iout,*) "Gather PRECOMP23"
-> c call flush(iout)
-> endif
-> isend=irecv
-> irecv=irecv-1
-> if (irecv.lt.0) irecv=nfgtasks1-1
-> enddo
-> #endif
-> time_gather=time_gather+MPI_Wtime()-time00
-> endif
-> #ifdef DEBUG
-> c if (fg_rank.eq.0) then
-> write (iout,*) "Arrays UG and UGDER"
-> do i=1,nres-1
-> write (iout,'(i5,4f10.5,5x,4f10.5)') i,
-> & ((ug(l,k,i),l=1,2),k=1,2),
-> & ((ugder(l,k,i),l=1,2),k=1,2)
-> enddo
-> write (iout,*) "Arrays UG2 and UG2DER"
-> do i=1,nres-1
-> write (iout,'(i5,4f10.5,5x,4f10.5)') i,
-> & ((ug2(l,k,i),l=1,2),k=1,2),
-> & ((ug2der(l,k,i),l=1,2),k=1,2)
-> enddo
-> write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
-> do i=1,nres-1
-> write (iout,'(i5,4f10.5,5x,4f10.5)') i,
-> & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
-> & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
-> enddo
-> write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
-> do i=1,nres-1
-> write (iout,'(i5,4f10.5,5x,4f10.5)') i,
-> & costab(i),sintab(i),costab2(i),sintab2(i)
-> enddo
-> write (iout,*) "Array MUDER"
-> do i=1,nres-1
-> write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
-> enddo
-> c endif
-> #endif
-> #endif
-1768a2657,2659
-> #ifdef MPI
-> include 'mpif.h'
-> #endif
-1770d2660
-< include 'DIMENSIONS.ZSCOPT'
-1771a2662
-> include 'COMMON.SETUP'
-1782a2674
-> include 'COMMON.TIME1'
-1787c2679,2681
-< common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
----
-> common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
-> & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
-> & num_conti,j1,j2
-1788a2683,2685
-> #ifdef MOMENT
-> double precision scal_el /1.0d0/
-> #else
-1789a2687
-> #endif
-1818,1823c2716,2719
-< cd if (wel_loc.gt.0.0d0) then
-< if (icheckgrad.eq.1) then
-< call vec_and_deriv_test
-< else
-< call vec_and_deriv
-< endif
----
-> c call vec_and_deriv
-> #ifdef TIMING
-> time01=MPI_Wtime()
-> #endif
-1824a2721,2723
-> #ifdef TIMING
-> time_mat=time_mat+MPI_Wtime()-time01
-> #endif
-1829c2728
-< cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
----
-> cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
-1836c2735
-< num_conti_hb=0
----
-> t_eelecij=0.0d0
-1851a2751,2795
-> c
-> c
-> c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
-> C
-> C Loop over i,i+2 and i,i+3 pairs of the peptide groups
-> C
-> do i=iturn3_start,iturn3_end
-> if (itype(i).eq.21 .or. itype(i+1).eq.21
-> & .or. itype(i+2).eq.21 .or. itype(i+3).eq.21) cycle
-> dxi=dc(1,i)
-> dyi=dc(2,i)
-> dzi=dc(3,i)
-> dx_normi=dc_norm(1,i)
-> dy_normi=dc_norm(2,i)
-> dz_normi=dc_norm(3,i)
-> xmedi=c(1,i)+0.5d0*dxi
-> ymedi=c(2,i)+0.5d0*dyi
-> zmedi=c(3,i)+0.5d0*dzi
-> num_conti=0
-> call eelecij(i,i+2,ees,evdw1,eel_loc)
-> if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
-> num_cont_hb(i)=num_conti
-> enddo
-> do i=iturn4_start,iturn4_end
-> if (itype(i).eq.21 .or. itype(i+1).eq.21
-> & .or. itype(i+3).eq.21
-> & .or. itype(i+4).eq.21) cycle
-> dxi=dc(1,i)
-> dyi=dc(2,i)
-> dzi=dc(3,i)
-> dx_normi=dc_norm(1,i)
-> dy_normi=dc_norm(2,i)
-> dz_normi=dc_norm(3,i)
-> xmedi=c(1,i)+0.5d0*dxi
-> ymedi=c(2,i)+0.5d0*dyi
-> zmedi=c(3,i)+0.5d0*dzi
-> num_conti=num_cont_hb(i)
-> call eelecij(i,i+3,ees,evdw1,eel_loc)
-> if (wturn4.gt.0.0d0 .and. itype(i+2).ne.21)
-> & call eturn4(i,eello_turn4)
-> num_cont_hb(i)=num_conti
-> enddo ! i
-> c
-> c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
-> c
-1854d2797
-< if (itel(i).eq.0) goto 1215
-1864d2806
-< num_conti=0
-1865a2808
-> num_conti=num_cont_hb(i)
-1866a2810
-> c write (iout,*) i,j,itype(i),itype(j)
-1868,1869c2812,2866
-< if (itel(j).eq.0) goto 1216
-< ind=ind+1
----
-> call eelecij(i,j,ees,evdw1,eel_loc)
-> enddo ! j
-> num_cont_hb(i)=num_conti
-> enddo ! i
-> c write (iout,*) "Number of loop steps in EELEC:",ind
-> cd do i=1,nres
-> cd write (iout,'(i3,3f10.5,5x,3f10.5)')
-> cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
-> cd enddo
-> c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
-> ccc eel_loc=eel_loc+eello_turn3
-> cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
-> return
-> end
-> C-------------------------------------------------------------------------------
-> subroutine eelecij(i,j,ees,evdw1,eel_loc)
-> implicit real*8 (a-h,o-z)
-> include 'DIMENSIONS'
-> #ifdef MPI
-> include "mpif.h"
-> #endif
-> include 'COMMON.CONTROL'
-> include 'COMMON.IOUNITS'
-> include 'COMMON.GEO'
-> include 'COMMON.VAR'
-> include 'COMMON.LOCAL'
-> include 'COMMON.CHAIN'
-> include 'COMMON.DERIV'
-> include 'COMMON.INTERACT'
-> include 'COMMON.CONTACTS'
-> include 'COMMON.TORSION'
-> include 'COMMON.VECTORS'
-> include 'COMMON.FFIELD'
-> include 'COMMON.TIME1'
-> dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
-> & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
-> double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
-> & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
-> common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
-> & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
-> & num_conti,j1,j2
-> c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
-> #ifdef MOMENT
-> double precision scal_el /1.0d0/
-> #else
-> double precision scal_el /0.5d0/
-> #endif
-> C 12/13/98
-> C 13-go grudnia roku pamietnego...
-> double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
-> & 0.0d0,1.0d0,0.0d0,
-> & 0.0d0,0.0d0,1.0d0/
-> c time00=MPI_Wtime()
-> cd write (iout,*) "eelecij",i,j
-> c ind=ind+1
-1875,1880d2871
-< C Diagnostics only!!!
-< c aaa=0.0D0
-< c bbb=0.0D0
-< c ael6i=0.0D0
-< c ael3i=0.0D0
-< C End diagnostics
-1912d2902
-< c write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
-1920a2911,2916
->
-> if (energy_dec) then
-> write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
-> write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
-> endif
->
-1925c2921
-< facvdw=-6*rrmij*(ev1+evdwij)
----
-> facvdw=-6*rrmij*(ev1+evdwij)
-1931d2926
-< if (calc_grad) then
-1934c2929
-< *
----
-> *
-1937a2933,2938
-> c do k=1,3
-> c ghalf=0.5D0*ggg(k)
-> c gelc(k,i)=gelc(k,i)+ghalf
-> c gelc(k,j)=gelc(k,j)+ghalf
-> c enddo
-> c 9/28/08 AL Gradient compotents will be summed only at the end
-1939,1941c2940,2941
-< ghalf=0.5D0*ggg(k)
-< gelc(k,i)=gelc(k,i)+ghalf
-< gelc(k,j)=gelc(k,j)+ghalf
----
-> gelc_long(k,j)=gelc_long(k,j)+ggg(k)
-> gelc_long(k,i)=gelc_long(k,i)-ggg(k)
-1946,1950c2946,2950
-< do k=i+1,j-1
-< do l=1,3
-< gelc(l,k)=gelc(l,k)+ggg(l)
-< enddo
-< enddo
----
-> cgrad do k=i+1,j-1
-> cgrad do l=1,3
-> cgrad gelc(l,k)=gelc(l,k)+ggg(l)
-> cgrad enddo
-> cgrad enddo
-1953a2954,2959
-> c do k=1,3
-> c ghalf=0.5D0*ggg(k)
-> c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
-> c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
-> c enddo
-> c 9/28/08 AL Gradient compotents will be summed only at the end
-1955,1957c2961,2962
-< ghalf=0.5D0*ggg(k)
-< gvdwpp(k,i)=gvdwpp(k,i)+ghalf
-< gvdwpp(k,j)=gvdwpp(k,j)+ghalf
----
-> gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
-> gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
-1962,1966c2967,2971
-< do k=i+1,j-1
-< do l=1,3
-< gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
-< enddo
-< enddo
----
-> cgrad do k=i+1,j-1
-> cgrad do l=1,3
-> cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
-> cgrad enddo
-> cgrad enddo
-1975d2979
-< if (calc_grad) then
-1981a2986,2991
-> c do k=1,3
-> c ghalf=0.5D0*ggg(k)
-> c gelc(k,i)=gelc(k,i)+ghalf
-> c gelc(k,j)=gelc(k,j)+ghalf
-> c enddo
-> c 9/28/08 AL Gradient compotents will be summed only at the end
-1983,1985c2993,2994
-< ghalf=0.5D0*ggg(k)
-< gelc(k,i)=gelc(k,i)+ghalf
-< gelc(k,j)=gelc(k,j)+ghalf
----
-> gelc_long(k,j)=gelc(k,j)+ggg(k)
-> gelc_long(k,i)=gelc(k,i)-ggg(k)
-1990,1993c2999,3010
-< do k=i+1,j-1
-< do l=1,3
-< gelc(l,k)=gelc(l,k)+ggg(l)
-< enddo
----
-> cgrad do k=i+1,j-1
-> cgrad do l=1,3
-> cgrad gelc(l,k)=gelc(l,k)+ggg(l)
-> cgrad enddo
-> cgrad enddo
-> c 9/28/08 AL Gradient compotents will be summed only at the end
-> ggg(1)=facvdw*xj
-> ggg(2)=facvdw*yj
-> ggg(3)=facvdw*zj
-> do k=1,3
-> gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
-> gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
-2012a3030,3043
-> c do k=1,3
-> c ghalf=0.5D0*ggg(k)
-> c gelc(k,i)=gelc(k,i)+ghalf
-> c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
-> c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
-> c gelc(k,j)=gelc(k,j)+ghalf
-> c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
-> c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
-> c enddo
-> cgrad do k=i+1,j-1
-> cgrad do l=1,3
-> cgrad gelc(l,k)=gelc(l,k)+ggg(l)
-> cgrad enddo
-> cgrad enddo
-2014,2015c3045
-< ghalf=0.5D0*ggg(k)
-< gelc(k,i)=gelc(k,i)+ghalf
----
-> gelc(k,i)=gelc(k,i)
-2018c3048
-< gelc(k,j)=gelc(k,j)+ghalf
----
-> gelc(k,j)=gelc(k,j)
-2020a3051,3052
-> gelc_long(k,j)=gelc_long(k,j)+ggg(k)
-> gelc_long(k,i)=gelc_long(k,i)-ggg(k)
-2022,2028d3053
-< do k=i+1,j-1
-< do l=1,3
-< gelc(l,k)=gelc(l,k)+ggg(l)
-< enddo
-< enddo
-< endif
-<
-2064,2068d3088
-< C For diagnostics only
-< cd a22=1.0d0
-< cd a23=1.0d0
-< cd a32=1.0d0
-< cd a33=1.0d0
-2070,2072d3089
-< cd write (2,*) 'fac=',fac
-< C For diagnostics only
-< cd fac=1.0d0
-2080,2081c3097,3098
-< cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
-< cd & (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
----
-> cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
-> cd & uy(:,j),uz(:,j)
-2086c3103
-< cd write (iout,'(2i3,9f10.5/)') i,j,
----
-> cd write (iout,'(9f10.5/)')
-2088d3104
-< if (calc_grad) then
-2090,2095c3106
-< call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
-< cd do k=1,3
-< cd do l=1,3
-< cd erder(k,l)=0.0d0
-< cd enddo
-< cd enddo
----
-> call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
-2110,2117d3120
-< cd do k=1,3
-< cd do l=1,3
-< cd uryg(k,l)=0.0d0
-< cd urzg(k,l)=0.0d0
-< cd vryg(k,l)=0.0d0
-< cd vrzg(k,l)=0.0d0
-< cd enddo
-< cd enddo
-2124,2127d3126
-< cd a22der=0.0d0
-< cd a23der=0.0d0
-< cd a32der=0.0d0
-< cd a33der=0.0d0
-2150,2153c3149,3152
-< ghalf1=0.5d0*agg(k,1)
-< ghalf2=0.5d0*agg(k,2)
-< ghalf3=0.5d0*agg(k,3)
-< ghalf4=0.5d0*agg(k,4)
----
-> cgrad ghalf1=0.5d0*agg(k,1)
-> cgrad ghalf2=0.5d0*agg(k,2)
-> cgrad ghalf3=0.5d0*agg(k,3)
-> cgrad ghalf4=0.5d0*agg(k,4)
-2155c3154
-< & -3.0d0*uryg(k,2)*vry)+ghalf1
----
-> & -3.0d0*uryg(k,2)*vry)!+ghalf1
-2157c3156
-< & -3.0d0*uryg(k,2)*vrz)+ghalf2
----
-> & -3.0d0*uryg(k,2)*vrz)!+ghalf2
-2159c3158
-< & -3.0d0*urzg(k,2)*vry)+ghalf3
----
-> & -3.0d0*urzg(k,2)*vry)!+ghalf3
-2161c3160
-< & -3.0d0*urzg(k,2)*vrz)+ghalf4
----
-> & -3.0d0*urzg(k,2)*vrz)!+ghalf4
-2164c3163
-< & -3.0d0*uryg(k,3)*vry)+agg(k,1)
----
-> & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
-2166c3165
-< & -3.0d0*uryg(k,3)*vrz)+agg(k,2)
----
-> & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
-2168c3167
-< & -3.0d0*urzg(k,3)*vry)+agg(k,3)
----
-> & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
-2170c3169
-< & -3.0d0*urzg(k,3)*vrz)+agg(k,4)
----
-> & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
-2173c3172
-< & -3.0d0*vryg(k,2)*ury)+ghalf1
----
-> & -3.0d0*vryg(k,2)*ury)!+ghalf1
-2175c3174
-< & -3.0d0*vrzg(k,2)*ury)+ghalf2
----
-> & -3.0d0*vrzg(k,2)*ury)!+ghalf2
-2177c3176
-< & -3.0d0*vryg(k,2)*urz)+ghalf3
----
-> & -3.0d0*vryg(k,2)*urz)!+ghalf3
-2179c3178
-< & -3.0d0*vrzg(k,2)*urz)+ghalf4
----
-> & -3.0d0*vrzg(k,2)*urz)!+ghalf4
-2189,2213c3188,3192
-< cd aggi(k,1)=ghalf1
-< cd aggi(k,2)=ghalf2
-< cd aggi(k,3)=ghalf3
-< cd aggi(k,4)=ghalf4
-< C Derivatives in DC(i+1)
-< cd aggi1(k,1)=agg(k,1)
-< cd aggi1(k,2)=agg(k,2)
-< cd aggi1(k,3)=agg(k,3)
-< cd aggi1(k,4)=agg(k,4)
-< C Derivatives in DC(j)
-< cd aggj(k,1)=ghalf1
-< cd aggj(k,2)=ghalf2
-< cd aggj(k,3)=ghalf3
-< cd aggj(k,4)=ghalf4
-< C Derivatives in DC(j+1)
-< cd aggj1(k,1)=0.0d0
-< cd aggj1(k,2)=0.0d0
-< cd aggj1(k,3)=0.0d0
-< cd aggj1(k,4)=0.0d0
-< if (j.eq.nres-1 .and. i.lt.j-2) then
-< do l=1,4
-< aggj1(k,l)=aggj1(k,l)+agg(k,l)
-< cd aggj1(k,l)=agg(k,l)
-< enddo
-< endif
----
-> cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
-> cgrad do l=1,4
-> cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
-> cgrad enddo
-> cgrad endif
-2215,2217d3193
-< endif
-< c goto 11111
-< C Check the loc-el terms by numerical integration
-2261d3236
-< 11111 continue
-2267c3242,3245
-< cd write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
----
->
-> if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
-> & 'eelloc',i,j,eel_loc_ij
->
-2270d3247
-< if (calc_grad) then
-2278,2284d3254
-< cd call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
-< cd write(iout,*) 'agg ',agg
-< cd write(iout,*) 'aggi ',aggi
-< cd write(iout,*) 'aggi1',aggi1
-< cd write(iout,*) 'aggj ',aggj
-< cd write(iout,*) 'aggj1',aggj1
-<
-2289,2294c3259,3269
-< enddo
-< do k=i+2,j2
-< do l=1,3
-< gel_loc(l,k)=gel_loc(l,k)+ggg(l)
-< enddo
-< enddo
----
-> gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
-> gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
-> cgrad ghalf=0.5d0*ggg(l)
-> cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
-> cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
-> enddo
-> cgrad do k=i+1,j2
-> cgrad do l=1,3
-> cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
-> cgrad enddo
-> cgrad enddo
-2306d3280
-< endif
-2308,2315d3281
-< if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
-< C Contributions from turns
-< a_temp(1,1)=a22
-< a_temp(1,2)=a23
-< a_temp(2,1)=a32
-< a_temp(2,2)=a33
-< call eturn34(i,j,eello_turn3,eello_turn4)
-< endif
-2317c3283,3286
-< if (j.gt.i+1 .and. num_conti.le.maxconts) then
----
-> c if (j.gt.i+1 .and. num_conti.le.maxconts) then
-> if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
-> & .and. num_conti.le.maxconts) then
-> c write (iout,*) i,j," entered corr"
-2334a3304,3305
-> cd write (iout,*) "i",i," j",j," num_conti",num_conti,
-> cd & " jcont_hb",jcont_hb(num_conti,i)
-2350,2382d3320
-< c if (i.eq.1) then
-< c a_chuj(1,1,num_conti,i)=-0.61d0
-< c a_chuj(1,2,num_conti,i)= 0.4d0
-< c a_chuj(2,1,num_conti,i)= 0.65d0
-< c a_chuj(2,2,num_conti,i)= 0.50d0
-< c else if (i.eq.2) then
-< c a_chuj(1,1,num_conti,i)= 0.0d0
-< c a_chuj(1,2,num_conti,i)= 0.0d0
-< c a_chuj(2,1,num_conti,i)= 0.0d0
-< c a_chuj(2,2,num_conti,i)= 0.0d0
-< c endif
-< C --- and its gradients
-< cd write (iout,*) 'i',i,' j',j
-< cd do kkk=1,3
-< cd write (iout,*) 'iii 1 kkk',kkk
-< cd write (iout,*) agg(kkk,:)
-< cd enddo
-< cd do kkk=1,3
-< cd write (iout,*) 'iii 2 kkk',kkk
-< cd write (iout,*) aggi(kkk,:)
-< cd enddo
-< cd do kkk=1,3
-< cd write (iout,*) 'iii 3 kkk',kkk
-< cd write (iout,*) aggi1(kkk,:)
-< cd enddo
-< cd do kkk=1,3
-< cd write (iout,*) 'iii 4 kkk',kkk
-< cd write (iout,*) aggj(kkk,:)
-< cd enddo
-< cd do kkk=1,3
-< cd write (iout,*) 'iii 5 kkk',kkk
-< cd write (iout,*) aggj1(kkk,:)
-< cd enddo
-2393,2395d3330
-< c do mm=1,5
-< c a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
-< c enddo
-2408,2409c3343,3356
-< ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
-< ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
----
-> c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
-> ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
-> if (ees0tmp.gt.0) then
-> ees0pij=dsqrt(ees0tmp)
-> else
-> ees0pij=0
-> endif
-> c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
-> ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
-> if (ees0tmp.gt.0) then
-> ees0mij=dsqrt(ees0tmp)
-> else
-> ees0mij=0
-> endif
-2418,2421c3365,3366
-< c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
-< c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
-< facont_hb(num_conti,i)=fcont
-< if (calc_grad) then
----
-> c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
-> c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
-2448a3394
-> facont_hb(num_conti,i)=fcont
-2472,2474c3418,3424
-< ghalfp=0.5D0*gggp(k)
-< ghalfm=0.5D0*gggm(k)
-< gacontp_hb1(k,num_conti,i)=ghalfp
----
-> c
-> c 10/24/08 cgrad and ! comments indicate the parts of the code removed
-> c following the change of gradient-summation algorithm.
-> c
-> cgrad ghalfp=0.5D0*gggp(k)
-> cgrad ghalfm=0.5D0*gggm(k)
-> gacontp_hb1(k,num_conti,i)=!ghalfp
-2477c3427
-< gacontp_hb2(k,num_conti,i)=ghalfp
----
-> gacontp_hb2(k,num_conti,i)=!ghalfp
-2481c3431
-< gacontm_hb1(k,num_conti,i)=ghalfm
----
-> gacontm_hb1(k,num_conti,i)=!ghalfm
-2484c3434
-< gacontm_hb2(k,num_conti,i)=ghalfm
----
-> gacontm_hb2(k,num_conti,i)=!ghalfm
-2489d3438
-< endif
-2503,2513c3452,3469
-< 1216 continue
-< enddo ! j
-< num_cont_hb(i)=num_conti
-< 1215 continue
-< enddo ! i
-< cd do i=1,nres
-< cd write (iout,'(i3,3f10.5,5x,3f10.5)')
-< cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
-< cd enddo
-< c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
-< ccc eel_loc=eel_loc+eello_turn3
----
-> if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
-> do k=1,4
-> do l=1,3
-> ghalf=0.5d0*agg(l,k)
-> aggi(l,k)=aggi(l,k)+ghalf
-> aggi1(l,k)=aggi1(l,k)+agg(l,k)
-> aggj(l,k)=aggj(l,k)+ghalf
-> enddo
-> enddo
-> if (j.eq.nres-1 .and. i.lt.j-2) then
-> do k=1,4
-> do l=1,3
-> aggj1(l,k)=aggj1(l,k)+agg(l,k)
-> enddo
-> enddo
-> endif
-> endif
-> c t_eelecij=t_eelecij+MPI_Wtime()-time00
-2517c3473
-< subroutine eturn34(i,j,eello_turn3,eello_turn4)
----
-> subroutine eturn3(i,eello_turn3)
-2521d3476
-< include 'DIMENSIONS.ZSCOPT'
-2532a3488
-> include 'COMMON.CONTROL'
-2538,2540c3494,3503
-< & aggj(3,4),aggj1(3,4),a_temp(2,2)
-< common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
-< if (j.eq.i+2) then
----
-> & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
-> common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
-> & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
-> & num_conti,j1,j2
-> j=i+2
-> c write (iout,*) "eturn3",i,j,j1,j2
-> a_temp(1,1)=a22
-> a_temp(1,2)=a23
-> a_temp(2,1)=a32
-> a_temp(2,2)=a33
-2555a3519,3520
-> if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
-> & 'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
-2559d3523
-< if (calc_grad) then
-2562,2563c3526,3527
-< call transpose2(auxmat2(1,1),pizda(1,1))
-< call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
----
-> call transpose2(auxmat2(1,1),auxmat3(1,1))
-> call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
-2567,2568c3531,3532
-< call transpose2(auxmat2(1,1),pizda(1,1))
-< call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
----
-> call transpose2(auxmat2(1,1),auxmat3(1,1))
-> call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
-2573,2576c3537,3544
-< a_temp(1,1)=aggi(l,1)
-< a_temp(1,2)=aggi(l,2)
-< a_temp(2,1)=aggi(l,3)
-< a_temp(2,2)=aggi(l,4)
----
-> c ghalf1=0.5d0*agg(l,1)
-> c ghalf2=0.5d0*agg(l,2)
-> c ghalf3=0.5d0*agg(l,3)
-> c ghalf4=0.5d0*agg(l,4)
-> a_temp(1,1)=aggi(l,1)!+ghalf1
-> a_temp(1,2)=aggi(l,2)!+ghalf2
-> a_temp(2,1)=aggi(l,3)!+ghalf3
-> a_temp(2,2)=aggi(l,4)!+ghalf4
-2580,2583c3548,3551
-< a_temp(1,1)=aggi1(l,1)
-< a_temp(1,2)=aggi1(l,2)
-< a_temp(2,1)=aggi1(l,3)
-< a_temp(2,2)=aggi1(l,4)
----
-> a_temp(1,1)=aggi1(l,1)!+agg(l,1)
-> a_temp(1,2)=aggi1(l,2)!+agg(l,2)
-> a_temp(2,1)=aggi1(l,3)!+agg(l,3)
-> a_temp(2,2)=aggi1(l,4)!+agg(l,4)
-2587,2590c3555,3558
-< a_temp(1,1)=aggj(l,1)
-< a_temp(1,2)=aggj(l,2)
-< a_temp(2,1)=aggj(l,3)
-< a_temp(2,2)=aggj(l,4)
----
-> a_temp(1,1)=aggj(l,1)!+ghalf1
-> a_temp(1,2)=aggj(l,2)!+ghalf2
-> a_temp(2,1)=aggj(l,3)!+ghalf3
-> a_temp(2,2)=aggj(l,4)!+ghalf4
-2602,2603c3570,3598
-< endif
-< else if (j.eq.i+3 .and. itype(i+2).ne.21) then
----
-> return
-> end
-> C-------------------------------------------------------------------------------
-> subroutine eturn4(i,eello_turn4)
-> C Third- and fourth-order contributions from turns
-> implicit real*8 (a-h,o-z)
-> include 'DIMENSIONS'
-> include 'COMMON.IOUNITS'
-> include 'COMMON.GEO'
-> include 'COMMON.VAR'
-> include 'COMMON.LOCAL'
-> include 'COMMON.CHAIN'
-> include 'COMMON.DERIV'
-> include 'COMMON.INTERACT'
-> include 'COMMON.CONTACTS'
-> include 'COMMON.TORSION'
-> include 'COMMON.VECTORS'
-> include 'COMMON.FFIELD'
-> include 'COMMON.CONTROL'
-> dimension ggg(3)
-> double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
-> & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
-> & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
-> double precision agg(3,4),aggi(3,4),aggi1(3,4),
-> & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
-> common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
-> & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
-> & num_conti,j1,j2
-> j=i+3
-2615a3611,3615
-> c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
-> a_temp(1,1)=a22
-> a_temp(1,2)=a23
-> a_temp(2,1)=a32
-> a_temp(2,2)=a33
-2618a3619
-> c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
-2631a3633,3634
-> if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
-> & 'eturn4',i,j,-(s1+s2+s3)
-2635d3637
-< if (calc_grad) then
-2658,2659c3660,3661
-< call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
-< call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
----
-> call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
-> call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
-2739a3742
-> c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
-2742,2743d3744
-< endif
-< endif
-2779a3781,3877
-> subroutine escp_soft_sphere(evdw2,evdw2_14)
-> C
-> C This subroutine calculates the excluded-volume interaction energy between
-> C peptide-group centers and side chains and its gradient in virtual-bond and
-> C side-chain vectors.
-> C
-> implicit real*8 (a-h,o-z)
-> include 'DIMENSIONS'
-> include 'COMMON.GEO'
-> include 'COMMON.VAR'
-> include 'COMMON.LOCAL'
-> include 'COMMON.CHAIN'
-> include 'COMMON.DERIV'
-> include 'COMMON.INTERACT'
-> include 'COMMON.FFIELD'
-> include 'COMMON.IOUNITS'
-> include 'COMMON.CONTROL'
-> dimension ggg(3)
-> evdw2=0.0D0
-> evdw2_14=0.0d0
-> r0_scp=4.5d0
-> cd print '(a)','Enter ESCP'
-> cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
-> do i=iatscp_s,iatscp_e
-> if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
-> iteli=itel(i)
-> xi=0.5D0*(c(1,i)+c(1,i+1))
-> yi=0.5D0*(c(2,i)+c(2,i+1))
-> zi=0.5D0*(c(3,i)+c(3,i+1))
->
-> do iint=1,nscp_gr(i)
->
-> do j=iscpstart(i,iint),iscpend(i,iint)
-> if (itype(j).eq.21) cycle
-> itypj=itype(j)
-> C Uncomment following three lines for SC-p interactions
-> c xj=c(1,nres+j)-xi
-> c yj=c(2,nres+j)-yi
-> c zj=c(3,nres+j)-zi
-> C Uncomment following three lines for Ca-p interactions
-> xj=c(1,j)-xi
-> yj=c(2,j)-yi
-> zj=c(3,j)-zi
-> rij=xj*xj+yj*yj+zj*zj
-> r0ij=r0_scp
-> r0ijsq=r0ij*r0ij
-> if (rij.lt.r0ijsq) then
-> evdwij=0.25d0*(rij-r0ijsq)**2
-> fac=rij-r0ijsq
-> else
-> evdwij=0.0d0
-> fac=0.0d0
-> endif
-> evdw2=evdw2+evdwij
-> C
-> C Calculate contributions to the gradient in the virtual-bond and SC vectors.
-> C
-> ggg(1)=xj*fac
-> ggg(2)=yj*fac
-> ggg(3)=zj*fac
-> cgrad if (j.lt.i) then
-> cd write (iout,*) 'j<i'
-> C Uncomment following three lines for SC-p interactions
-> c do k=1,3
-> c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
-> c enddo
-> cgrad else
-> cd write (iout,*) 'j>i'
-> cgrad do k=1,3
-> cgrad ggg(k)=-ggg(k)
-> C Uncomment following line for SC-p interactions
-> c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
-> cgrad enddo
-> cgrad endif
-> cgrad do k=1,3
-> cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
-> cgrad enddo
-> cgrad kstart=min0(i+1,j)
-> cgrad kend=max0(i-1,j-1)
-> cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
-> cd write (iout,*) ggg(1),ggg(2),ggg(3)
-> cgrad do k=kstart,kend
-> cgrad do l=1,3
-> cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
-> cgrad enddo
-> cgrad enddo
-> do k=1,3
-> gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
-> gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
-> enddo
-> enddo
->
-> enddo ! iint
-> enddo ! i
-> return
-> end
-> C-----------------------------------------------------------------------------
-2788d3885
-< include 'DIMENSIONS.ZSCOPT'
-2796a3894
-> include 'COMMON.CONTROL'
-2801,2802c3899
-< c write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
-< c & ' scal14',scal14
----
-> cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
-2806,2808d3902
-< c write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
-< c & " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
-< if (iteli.eq.0) goto 1225
-2836d3929
-< c write (iout,*) i,j,evdwij
-2838c3931,3932
-< if (calc_grad) then
----
-> if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
-> & 'evdw2',i,j,evdwij
-2846c3940
-< if (j.lt.i) then
----
-> cgrad if (j.lt.i) then
-2852c3946
-< else
----
-> cgrad else
-2854,2855c3948,3949
-< do k=1,3
-< ggg(k)=-ggg(k)
----
-> cgrad do k=1,3
-> cgrad ggg(k)=-ggg(k)
-2857,2864c3951,3959
-< c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
-< enddo
-< endif
-< do k=1,3
-< gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
-< enddo
-< kstart=min0(i+1,j)
-< kend=max0(i-1,j-1)
----
-> ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
-> c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
-> cgrad enddo
-> cgrad endif
-> cgrad do k=1,3
-> cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
-> cgrad enddo
-> cgrad kstart=min0(i+1,j)
-> cgrad kend=max0(i-1,j-1)
-2867,2870c3962,3969
-< do k=kstart,kend
-< do l=1,3
-< gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
-< enddo
----
-> cgrad do k=kstart,kend
-> cgrad do l=1,3
-> cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
-> cgrad enddo
-> cgrad enddo
-> do k=1,3
-> gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
-> gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
-2872d3970
-< endif
-2873a3972
->
-2875d3973
-< 1225 continue
-2879a3978
-> gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
-2901d3999
-< include 'DIMENSIONS.ZSCOPT'
-2906a4005
-> include 'COMMON.IOUNITS'
-2909,2910c4008,4009
-< cd print *,'edis: nhpb=',nhpb,' fbr=',fbr
-< cd print *,'link_start=',link_start,' link_end=',link_end
----
-> cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
-> cd write(iout,*)'link_start=',link_start,' link_end=',link_end
-2924a4024
-> cd write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
-2929a4030
-> cd write (iout,*) "eij",eij
-2957,2960c4058,4065
-< do j=iii,jjj-1
-< do k=1,3
-< ghpbc(k,j)=ghpbc(k,j)+ggg(k)
-< enddo
----
-> cgrad do j=iii,jjj-1
-> cgrad do k=1,3
-> cgrad ghpbc(k,j)=ghpbc(k,j)+ggg(k)
-> cgrad enddo
-> cgrad enddo
-> do k=1,3
-> ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
-> ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
-2978d4082
-< include 'DIMENSIONS.ZSCOPT'
-2994c4098,4099
-< dsci_inv=dsc_inv(itypi)
----
-> c dsci_inv=dsc_inv(itypi)
-> dsci_inv=vbld_inv(nres+i)
-2996c4101,4102
-< dscj_inv=dsc_inv(itypj)
----
-> c dscj_inv=dsc_inv(itypj)
-> dscj_inv=vbld_inv(nres+j)
-3034,3040c4140,4148
-< gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
-< enddo
-< do k=1,3
-< ghpbx(k,i)=ghpbx(k,i)-gg(k)
-< & +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
-< ghpbx(k,j)=ghpbx(k,j)+gg(k)
-< & +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
----
-> ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
-> ghpbx(k,i)=ghpbx(k,i)-ggk
-> & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
-> & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
-> ghpbx(k,j)=ghpbx(k,j)+ggk
-> & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
-> & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
-> ghpbc(k,i)=ghpbc(k,i)-ggk
-> ghpbc(k,j)=ghpbc(k,j)+ggk
-3045,3049c4153,4157
-< do k=i,j-1
-< do l=1,3
-< ghpbc(l,k)=ghpbc(l,k)+gg(l)
-< enddo
-< enddo
----
-> cgrad do k=i,j-1
-> cgrad do l=1,3
-> cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)
-> cgrad enddo
-> cgrad enddo
-3059d4166
-< include 'DIMENSIONS.ZSCOPT'
-3070c4177
-< logical energy_dec /.false./
----
-> include 'COMMON.SETUP'
-3073,3074c4180,4181
-< write (iout,*) "distchainmax",distchainmax
-< do i=nnt+1,nct
----
-> estr1=0.0d0
-> do i=ibondp_start,ibondp_end
-3081c4188
-< if (energy_dec) write(iout,*)
----
-> if (energy_dec) write(iout,*)
-3085,3090c4192,4199
-< diff = vbld(i)-vbldp0
-< c write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
-< estr=estr+diff*diff
-< do j=1,3
-< gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
-< enddo
----
-> diff = vbld(i)-vbldp0
-> if (energy_dec) write (iout,*)
-> & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
-> estr=estr+diff*diff
-> do j=1,3
-> gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
-> enddo
-> c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
-3092d4200
-<
-3094c4202
-< estr=0.5d0*AKP*estr
----
-> estr=0.5d0*AKP*estr+estr1
-3098c4206
-< do i=nnt,nct
----
-> do i=ibond_start,ibond_end
-3104,3105c4212,4214
-< c write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
-< c & AKSC(1,iti),AKSC(1,iti)*diff*diff
----
-> if (energy_dec) write (iout,*)
-> & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
-> & AKSC(1,iti),AKSC(1,iti)*diff*diff
-3112c4221
-< diff=vbld(i+nres)-vbldsc0(j,iti)
----
-> diff=vbld(i+nres)-vbldsc0(j,iti)
-3132c4241
-< usumsqder=usumsqder+ud(j)*uprod2
----
-> usumsqder=usumsqder+ud(j)*uprod2
-3134,3135d4242
-< c write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
-< c & AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
-3144c4251
-< end
----
-> end
-3154d4260
-< include 'DIMENSIONS.ZSCOPT'
-3163a4270
-> include 'COMMON.CONTROL'
-3169,3170c4276,4277
-< time11=dexp(-2*time)
-< time12=1.0d0
----
-> c time11=dexp(-2*time)
-> c time12=1.0d0
-3172d4278
-< c write (iout,*) "nres",nres
-3174d4279
-< c write (iout,*) ithet_start,ithet_end
-3182,3185c4287,4288
-< phii=phi(i)
-< icrc=0
-< call proc_proc(phii,icrc)
-< if (icrc.eq.1) phii=150.0
----
-> phii=phi(i)
-> if (phii.ne.phii) phii=150.0
-3191c4294
-< else
----
-> else
-3197,3200c4300,4301
-< phii1=phi(i+1)
-< icrc=0
-< call proc_proc(phii1,icrc)
-< if (icrc.eq.1) phii1=150.0
----
-> phii1=phi(i+1)
-> if (phii1.ne.phii1) phii1=150.0
-3211c4312
-< endif
----
-> endif
-3221d4321
-< c write (iout,*) "thet_pred_mean",thet_pred_mean
-3224d4323
-< c write (iout,*) "thet_pred_mean",thet_pred_mean
-3250,3251c4349,4350
-< c write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
-< c & rad2deg*phii,rad2deg*phii1,ethetai
----
-> if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
-> & 'ebend',i,ethetai
-3255d4353
-< 1215 continue
-3379d4476
-< include 'DIMENSIONS.ZSCOPT'
-3396d4492
-< c write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
-3449,3451d4544
-< c write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
-< c & " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
-< c call flush(iout)
-3571d4663
-< include 'DIMENSIONS.ZSCOPT'
-3580a4673
-> include 'COMMON.CONTROL'
-3598d4690
-< c write (iout,*) "i",i," x",x(1),x(2),x(3)
-3672c4764,4766
-< c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
----
-> if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
-> & 'escloc',i,escloci
-> c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
-3745a4840,4844
-> #ifdef OSF
-> adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
-> if(adexp.ne.adexp) adexp=1.0
-> expfac=dexp(adexp)
-> #else
-3746a4846
-> #endif
-3856d4955
-< include 'DIMENSIONS.ZSCOPT'
-3991,3992c5090
-< c write (2,*) "escloc",escloc
-< if (.not. calc_grad) goto 1
----
-> c write (2,*) "i",i," escloc",sumene,escloc
-4168a5267,5304
-> c------------------------------------------------------------------------------
-> double precision function enesc(x,xx,yy,zz,cost2,sint2)
-> implicit none
-> double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
-> & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
-> sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
-> & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
-> & + x(10)*yy*zz
-> sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
-> & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
-> & + x(20)*yy*zz
-> sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
-> & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
-> & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
-> & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
-> & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
-> & +x(40)*xx*yy*zz
-> sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
-> & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
-> & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
-> & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
-> & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
-> & +x(60)*xx*yy*zz
-> dsc_i = 0.743d0+x(61)
-> dp2_i = 1.9d0+x(62)
-> dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
-> & *(xx*cost2+yy*sint2))
-> dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
-> & *(xx*cost2-yy*sint2))
-> s1=(1+x(63))/(0.1d0 + dscp1)
-> s1_6=(1+x(64))/(0.1d0 + dscp1**6)
-> s2=(1+x(65))/(0.1d0 + dscp2)
-> s2_6=(1+x(65))/(0.1d0 + dscp2**6)
-> sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
-> & + (sumene4*cost2 +sumene2)*(s2+s2_6)
-> enesc=sumene
-> return
-> end
-4207d5342
-< include 'DIMENSIONS.ZSCOPT'
-4252c5387
-< subroutine etor(etors,edihcnstr,fact)
----
-> subroutine etor(etors,edihcnstr)
-4255d5389
-< include 'DIMENSIONS.ZSCOPT'
-4266a5401
-> include 'COMMON.CONTROL'
-4273c5408,5409
-< if (itype(i-2).eq.21 .or. itype(i-1).eq.21
----
-> etors_ii=0.0D0
-> if (itype(i-2).eq.21 .or. itype(i-1).eq.21
-4286a5423
-> if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
-4294a5432,5433
-> if (energy_dec) etors_ii=etors_ii+
-> & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
-4303a5443,5444
-> if (energy_dec) etors_ii=etors_ii+
-> & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
-4306a5448,5449
-> if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
-> 'etor',i,etors_ii
-4311c5454
-< gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
----
-> gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
-4335a5479,5483
-> subroutine etor_d(etors_d)
-> etors_d=0.0d0
-> return
-> end
-> c----------------------------------------------------------------------------
-4337c5485
-< subroutine etor(etors,edihcnstr,fact)
----
-> subroutine etor(etors,edihcnstr)
-4340d5487
-< include 'DIMENSIONS.ZSCOPT'
-4351a5499
-> include 'COMMON.CONTROL'
-4355c5503
-< c lprn=.true.
----
-> c lprn=.true.
-4358c5506
-< if (itype(i-2).eq.21 .or. itype(i-1).eq.21
----
-> if (itype(i-2).eq.21 .or. itype(i-1).eq.21
-4360c5508
-< if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
----
-> etors_ii=0.0D0
-4371a5520,5521
-> if (energy_dec) etors_ii=etors_ii+
-> & v1ij*cosphi+v2ij*sinphi
-4387a5538,5539
-> if (energy_dec) etors_ii=etors_ii+
-> & vl1ij*pom1
-4392a5545,5546
-> if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
-> & 'etor',i,etors_ii-v0(itori,itori1)
-4397c5551
-< gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
----
-> gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
-4399d5552
-< 1215 continue
-4403c5556,5557
-< do i=1,ndih_constr
----
-> c do i=1,ndih_constr
-> do i=idihconstr_start,idihconstr_end
-4407d5560
-< edihi=0.0d0
-4412d5564
-< edihi=0.25d0*ftors*difi**4
-4417d5568
-< edihi=0.25d0*ftors*difi**4
-4419c5570
-< difi=0.0d0
----
-> difi=0.0
-4421,4424c5572,5574
-< c write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
-< c & drange(i),edihi
-< ! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
-< ! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
----
-> cd write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
-> cd & rad2deg*phi0(i), rad2deg*drange(i),
-> cd & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
-4426c5576
-< ! write (iout,*) 'edihcnstr',edihcnstr
----
-> cd write (iout,*) 'edihcnstr',edihcnstr
-4430c5580
-< subroutine etor_d(etors_d,fact2)
----
-> subroutine etor_d(etors_d)
-4434d5583
-< include 'DIMENSIONS.ZSCOPT'
-4451c5600
-< do i=iphi_start,iphi_end-1
----
-> do i=iphid_start,iphid_end
-4454,4455d5602
-< if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
-< & goto 1215
-4496,4498c5643,5644
-< gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
-< gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
-< 1215 continue
----
-> gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
-> gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
-4509c5655
-< c of residues computed from AM1 energy surfaces of terminally-blocked
----
-> c of residues computed from AM1 energy surfaces of terminally-blocked
-4513d5658
-< include 'DIMENSIONS.ZSCOPT'
-4551c5696
-< gsccor_loc(i-3)=gloci
----
-> gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
-4555c5700
-< c------------------------------------------------------------------------------
----
-> c----------------------------------------------------------------------------
-4638,4702c5783,5794
-< enddo
-< do m=i,j-1
-< do ll=1,3
-< gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
-< enddo
-< enddo
-< do m=k,l-1
-< do ll=1,3
-< gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
-< enddo
-< enddo
-< esccorr=-eij*ekl
-< return
-< end
-< c------------------------------------------------------------------------------
-< #ifdef MPL
-< subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
-< implicit real*8 (a-h,o-z)
-< include 'DIMENSIONS'
-< integer dimen1,dimen2,atom,indx
-< double precision buffer(dimen1,dimen2)
-< double precision zapas
-< common /contacts_hb/ zapas(3,20,maxres,7),
-< & facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
-< & num_cont_hb(maxres),jcont_hb(20,maxres)
-< num_kont=num_cont_hb(atom)
-< do i=1,num_kont
-< do k=1,7
-< do j=1,3
-< buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
-< enddo ! j
-< enddo ! k
-< buffer(i,indx+22)=facont_hb(i,atom)
-< buffer(i,indx+23)=ees0p(i,atom)
-< buffer(i,indx+24)=ees0m(i,atom)
-< buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
-< enddo ! i
-< buffer(1,indx+26)=dfloat(num_kont)
-< return
-< end
-< c------------------------------------------------------------------------------
-< subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
-< implicit real*8 (a-h,o-z)
-< include 'DIMENSIONS'
-< integer dimen1,dimen2,atom,indx
-< double precision buffer(dimen1,dimen2)
-< double precision zapas
-< common /contacts_hb/ zapas(3,20,maxres,7),
-< & facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
-< & num_cont_hb(maxres),jcont_hb(20,maxres)
-< num_kont=buffer(1,indx+26)
-< num_kont_old=num_cont_hb(atom)
-< num_cont_hb(atom)=num_kont+num_kont_old
-< do i=1,num_kont
-< ii=i+num_kont_old
-< do k=1,7
-< do j=1,3
-< zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
-< enddo ! j
-< enddo ! k
-< facont_hb(ii,atom)=buffer(i,indx+22)
-< ees0p(ii,atom)=buffer(i,indx+23)
-< ees0m(ii,atom)=buffer(i,indx+24)
-< jcont_hb(ii,atom)=buffer(i,indx+25)
-< enddo ! i
----
-> enddo
-> do m=i,j-1
-> do ll=1,3
-> gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
-> enddo
-> enddo
-> do m=k,l-1
-> do ll=1,3
-> gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
-> enddo
-> enddo
-> esccorr=-eij*ekl
-4706d5797
-< #endif
-4711d5801
-< include 'DIMENSIONS.ZSCOPT'
-4713,4714c5803,5812
-< #ifdef MPL
-< include 'COMMON.INFO'
----
-> #ifdef MPI
-> include "mpif.h"
-> parameter (max_cont=maxconts)
-> parameter (max_dim=26)
-> integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
-> double precision zapas(max_dim,maxconts,max_fg_procs),
-> & zapas_recv(max_dim,maxconts,max_fg_procs)
-> common /przechowalnia/ zapas
-> integer status(MPI_STATUS_SIZE),req(maxconts*2),
-> & status_array(MPI_STATUS_SIZE,maxconts*2)
-4715a5814
-> include 'COMMON.SETUP'
-4720,4728c5819,5821
-< #ifdef MPL
-< parameter (max_cont=maxconts)
-< parameter (max_dim=2*(8*3+2))
-< parameter (msglen1=max_cont*max_dim*4)
-< parameter (msglen2=2*msglen1)
-< integer source,CorrelType,CorrelID,Error
-< double precision buffer(max_cont,max_dim)
-< #endif
-< double precision gx(3),gx1(3)
----
-> include 'COMMON.CONTROL'
-> include 'COMMON.LOCAL'
-> double precision gx(3),gx1(3),time00
-4733c5826
-< #ifdef MPL
----
-> #ifdef MPI
-4736c5829
-< if (fgProcs.le.1) goto 30
----
-> if (nfgtasks.le.1) goto 30
-4738c5831
-< write (iout,'(a)') 'Contact function values:'
----
-> write (iout,'(a)') 'Contact function values before RECEIVE:'
-4745,4746c5838,5917
-< C Caution! Following code assumes that electrostatic interactions concerning
-< C a given atom are split among at most two processors!
----
-> call flush(iout)
-> do i=1,ntask_cont_from
-> ncont_recv(i)=0
-> enddo
-> do i=1,ntask_cont_to
-> ncont_sent(i)=0
-> enddo
-> c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
-> c & ntask_cont_to
-> C Make the list of contacts to send to send to other procesors
-> c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
-> c call flush(iout)
-> do i=iturn3_start,iturn3_end
-> c write (iout,*) "make contact list turn3",i," num_cont",
-> c & num_cont_hb(i)
-> call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
-> enddo
-> do i=iturn4_start,iturn4_end
-> c write (iout,*) "make contact list turn4",i," num_cont",
-> c & num_cont_hb(i)
-> call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
-> enddo
-> do ii=1,nat_sent
-> i=iat_sent(ii)
-> c write (iout,*) "make contact list longrange",i,ii," num_cont",
-> c & num_cont_hb(i)
-> do j=1,num_cont_hb(i)
-> do k=1,4
-> jjc=jcont_hb(j,i)
-> iproc=iint_sent_local(k,jjc,ii)
-> c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
-> if (iproc.gt.0) then
-> ncont_sent(iproc)=ncont_sent(iproc)+1
-> nn=ncont_sent(iproc)
-> zapas(1,nn,iproc)=i
-> zapas(2,nn,iproc)=jjc
-> zapas(3,nn,iproc)=facont_hb(j,i)
-> zapas(4,nn,iproc)=ees0p(j,i)
-> zapas(5,nn,iproc)=ees0m(j,i)
-> zapas(6,nn,iproc)=gacont_hbr(1,j,i)
-> zapas(7,nn,iproc)=gacont_hbr(2,j,i)
-> zapas(8,nn,iproc)=gacont_hbr(3,j,i)
-> zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
-> zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
-> zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
-> zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
-> zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
-> zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
-> zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
-> zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
-> zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
-> zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
-> zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
-> zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
-> zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
-> zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
-> zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
-> zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
-> zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
-> zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
-> endif
-> enddo
-> enddo
-> enddo
-> if (lprn) then
-> write (iout,*)
-> & "Numbers of contacts to be sent to other processors",
-> & (ncont_sent(i),i=1,ntask_cont_to)
-> write (iout,*) "Contacts sent"
-> do ii=1,ntask_cont_to
-> nn=ncont_sent(ii)
-> iproc=itask_cont_to(ii)
-> write (iout,*) nn," contacts to processor",iproc,
-> & " of CONT_TO_COMM group"
-> do i=1,nn
-> write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
-> enddo
-> enddo
-> call flush(iout)
-> endif
-4748,4836c5919,6040
-< CorrelID=MyID+1
-< ldone=.false.
-< do i=1,max_cont
-< do j=1,max_dim
-< buffer(i,j)=0.0D0
-< enddo
-< enddo
-< mm=mod(MyRank,2)
-< cd write (iout,*) 'MyRank',MyRank,' mm',mm
-< if (mm) 20,20,10
-< 10 continue
-< cd write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
-< if (MyRank.gt.0) then
-< C Send correlation contributions to the preceding processor
-< msglen=msglen1
-< nn=num_cont_hb(iatel_s)
-< call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
-< cd write (iout,*) 'The BUFFER array:'
-< cd do i=1,nn
-< cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
-< cd enddo
-< if (ielstart(iatel_s).gt.iatel_s+ispp) then
-< msglen=msglen2
-< call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
-< C Clear the contacts of the atom passed to the neighboring processor
-< nn=num_cont_hb(iatel_s+1)
-< cd do i=1,nn
-< cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
-< cd enddo
-< num_cont_hb(iatel_s)=0
-< endif
-< cd write (iout,*) 'Processor ',MyID,MyRank,
-< cd & ' is sending correlation contribution to processor',MyID-1,
-< cd & ' msglen=',msglen
-< cd write (*,*) 'Processor ',MyID,MyRank,
-< cd & ' is sending correlation contribution to processor',MyID-1,
-< cd & ' msglen=',msglen,' CorrelType=',CorrelType
-< call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
-< cd write (iout,*) 'Processor ',MyID,
-< cd & ' has sent correlation contribution to processor',MyID-1,
-< cd & ' msglen=',msglen,' CorrelID=',CorrelID
-< cd write (*,*) 'Processor ',MyID,
-< cd & ' has sent correlation contribution to processor',MyID-1,
-< cd & ' msglen=',msglen,' CorrelID=',CorrelID
-< msglen=msglen1
-< endif ! (MyRank.gt.0)
-< if (ldone) goto 30
-< ldone=.true.
-< 20 continue
-< cd write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
-< if (MyRank.lt.fgProcs-1) then
-< C Receive correlation contributions from the next processor
-< msglen=msglen1
-< if (ielend(iatel_e).lt.nct-1) msglen=msglen2
-< cd write (iout,*) 'Processor',MyID,
-< cd & ' is receiving correlation contribution from processor',MyID+1,
-< cd & ' msglen=',msglen,' CorrelType=',CorrelType
-< cd write (*,*) 'Processor',MyID,
-< cd & ' is receiving correlation contribution from processor',MyID+1,
-< cd & ' msglen=',msglen,' CorrelType=',CorrelType
-< nbytes=-1
-< do while (nbytes.le.0)
-< call mp_probe(MyID+1,CorrelType,nbytes)
-< enddo
-< cd print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
-< call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
-< cd write (iout,*) 'Processor',MyID,
-< cd & ' has received correlation contribution from processor',MyID+1,
-< cd & ' msglen=',msglen,' nbytes=',nbytes
-< cd write (iout,*) 'The received BUFFER array:'
-< cd do i=1,max_cont
-< cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
-< cd enddo
-< if (msglen.eq.msglen1) then
-< call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
-< else if (msglen.eq.msglen2) then
-< call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
-< call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
-< else
-< write (iout,*)
-< & 'ERROR!!!! message length changed while processing correlations.'
-< write (*,*)
-< & 'ERROR!!!! message length changed while processing correlations.'
-< call mp_stopall(Error)
-< endif ! msglen.eq.msglen1
-< endif ! MyRank.lt.fgProcs-1
-< if (ldone) goto 30
-< ldone=.true.
-< goto 10
----
-> CorrelID=fg_rank+1
-> CorrelType1=478
-> CorrelID1=nfgtasks+fg_rank+1
-> ireq=0
-> C Receive the numbers of needed contacts from other processors
-> do ii=1,ntask_cont_from
-> iproc=itask_cont_from(ii)
-> ireq=ireq+1
-> call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
-> & FG_COMM,req(ireq),IERR)
-> enddo
-> c write (iout,*) "IRECV ended"
-> c call flush(iout)
-> C Send the number of contacts needed by other processors
-> do ii=1,ntask_cont_to
-> iproc=itask_cont_to(ii)
-> ireq=ireq+1
-> call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
-> & FG_COMM,req(ireq),IERR)
-> enddo
-> c write (iout,*) "ISEND ended"
-> c write (iout,*) "number of requests (nn)",ireq
-> call flush(iout)
-> if (ireq.gt.0)
-> & call MPI_Waitall(ireq,req,status_array,ierr)
-> c write (iout,*)
-> c & "Numbers of contacts to be received from other processors",
-> c & (ncont_recv(i),i=1,ntask_cont_from)
-> c call flush(iout)
-> C Receive contacts
-> ireq=0
-> do ii=1,ntask_cont_from
-> iproc=itask_cont_from(ii)
-> nn=ncont_recv(ii)
-> c write (iout,*) "Receiving",nn," contacts from processor",iproc,
-> c & " of CONT_TO_COMM group"
-> call flush(iout)
-> if (nn.gt.0) then
-> ireq=ireq+1
-> call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
-> & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
-> c write (iout,*) "ireq,req",ireq,req(ireq)
-> endif
-> enddo
-> C Send the contacts to processors that need them
-> do ii=1,ntask_cont_to
-> iproc=itask_cont_to(ii)
-> nn=ncont_sent(ii)
-> c write (iout,*) nn," contacts to processor",iproc,
-> c & " of CONT_TO_COMM group"
-> if (nn.gt.0) then
-> ireq=ireq+1
-> call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
-> & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
-> c write (iout,*) "ireq,req",ireq,req(ireq)
-> c do i=1,nn
-> c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
-> c enddo
-> endif
-> enddo
-> c write (iout,*) "number of requests (contacts)",ireq
-> c write (iout,*) "req",(req(i),i=1,4)
-> c call flush(iout)
-> if (ireq.gt.0)
-> & call MPI_Waitall(ireq,req,status_array,ierr)
-> do iii=1,ntask_cont_from
-> iproc=itask_cont_from(iii)
-> nn=ncont_recv(iii)
-> if (lprn) then
-> write (iout,*) "Received",nn," contacts from processor",iproc,
-> & " of CONT_FROM_COMM group"
-> call flush(iout)
-> do i=1,nn
-> write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
-> enddo
-> call flush(iout)
-> endif
-> do i=1,nn
-> ii=zapas_recv(1,i,iii)
-> c Flag the received contacts to prevent double-counting
-> jj=-zapas_recv(2,i,iii)
-> c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
-> c call flush(iout)
-> nnn=num_cont_hb(ii)+1
-> num_cont_hb(ii)=nnn
-> jcont_hb(nnn,ii)=jj
-> facont_hb(nnn,ii)=zapas_recv(3,i,iii)
-> ees0p(nnn,ii)=zapas_recv(4,i,iii)
-> ees0m(nnn,ii)=zapas_recv(5,i,iii)
-> gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
-> gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
-> gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
-> gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
-> gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
-> gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
-> gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
-> gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
-> gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
-> gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
-> gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
-> gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
-> gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
-> gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
-> gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
-> gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
-> gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
-> gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
-> gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
-> gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
-> gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
-> enddo
-> enddo
-> call flush(iout)
-> if (lprn) then
-> write (iout,'(a)') 'Contact function values after receive:'
-> do i=nnt,nct-2
-> write (iout,'(2i3,50(1x,i3,f5.2))')
-> & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
-> & j=1,num_cont_hb(i))
-> enddo
-> call flush(iout)
-> endif
-4842c6046
-< write (iout,'(2i3,50(1x,i2,f5.2))')
----
-> write (iout,'(2i3,50(1x,i3,f5.2))')
-4856c6060
-< do i=iatel_s,iatel_e+1
----
-> do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
-4861a6066
-> jp=iabs(j)
-4863a6069
-> jp1=iabs(j1)
-4866c6072,6074
-< if (j1.eq.j+1 .or. j1.eq.j-1) then
----
-> if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
-> & .or. j.lt.0 .and. j1.gt.0) .and.
-> & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
-4869c6077,6079
-< ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
----
-> ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
-> if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
-> & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
-4891a6102,6158
-> subroutine add_hb_contact(ii,jj,itask)
-> implicit real*8 (a-h,o-z)
-> include "DIMENSIONS"
-> include "COMMON.IOUNITS"
-> integer max_cont
-> integer max_dim
-> parameter (max_cont=maxconts)
-> parameter (max_dim=26)
-> include "COMMON.CONTACTS"
-> double precision zapas(max_dim,maxconts,max_fg_procs),
-> & zapas_recv(max_dim,maxconts,max_fg_procs)
-> common /przechowalnia/ zapas
-> integer i,j,ii,jj,iproc,itask(4),nn
-> c write (iout,*) "itask",itask
-> do i=1,2
-> iproc=itask(i)
-> if (iproc.gt.0) then
-> do j=1,num_cont_hb(ii)
-> jjc=jcont_hb(j,ii)
-> c write (iout,*) "i",ii," j",jj," jjc",jjc
-> if (jjc.eq.jj) then
-> ncont_sent(iproc)=ncont_sent(iproc)+1
-> nn=ncont_sent(iproc)
-> zapas(1,nn,iproc)=ii
-> zapas(2,nn,iproc)=jjc
-> zapas(3,nn,iproc)=facont_hb(j,ii)
-> zapas(4,nn,iproc)=ees0p(j,ii)
-> zapas(5,nn,iproc)=ees0m(j,ii)
-> zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
-> zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
-> zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
-> zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
-> zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
-> zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
-> zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
-> zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
-> zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
-> zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
-> zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
-> zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
-> zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
-> zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
-> zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
-> zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
-> zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
-> zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
-> zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
-> zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
-> zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
-> exit
-> endif
-> enddo
-> endif
-> enddo
-> return
-> end
-> c------------------------------------------------------------------------------
-4897d6163
-< include 'DIMENSIONS.ZSCOPT'
-4899,4900c6165,6174
-< #ifdef MPL
-< include 'COMMON.INFO'
----
-> #ifdef MPI
-> include "mpif.h"
-> parameter (max_cont=maxconts)
-> parameter (max_dim=70)
-> integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
-> double precision zapas(max_dim,maxconts,max_fg_procs),
-> & zapas_recv(max_dim,maxconts,max_fg_procs)
-> common /przechowalnia/ zapas
-> integer status(MPI_STATUS_SIZE),req(maxconts*2),
-> & status_array(MPI_STATUS_SIZE,maxconts*2)
-4901a6176
-> include 'COMMON.SETUP'
-4903a6179
-> include 'COMMON.LOCAL'
-4906,4913c6182,6183
-< #ifdef MPL
-< parameter (max_cont=maxconts)
-< parameter (max_dim=2*(8*3+2))
-< parameter (msglen1=max_cont*max_dim*4)
-< parameter (msglen2=2*msglen1)
-< integer source,CorrelType,CorrelID,Error
-< double precision buffer(max_cont,max_dim)
-< #endif
----
-> include 'COMMON.CHAIN'
-> include 'COMMON.CONTROL'
-4914a6185
-> integer num_cont_hb_old(maxres)
-4916c6187,6188
-<
----
-> double precision eello4,eello5,eelo6,eello_turn6
-> external eello4,eello5,eello6,eello_turn6
-4920c6192,6195
-< #ifdef MPL
----
-> #ifdef MPI
-> do i=1,nres
-> num_cont_hb_old(i)=num_cont_hb(i)
-> enddo
-4923c6198
-< if (fgProcs.le.1) goto 30
----
-> if (nfgtasks.le.1) goto 30
-4925c6200
-< write (iout,'(a)') 'Contact function values:'
----
-> write (iout,'(a)') 'Contact function values before RECEIVE:'
-4932,4933c6207,6282
-< C Caution! Following code assumes that electrostatic interactions concerning
-< C a given atom are split among at most two processors!
----
-> call flush(iout)
-> do i=1,ntask_cont_from
-> ncont_recv(i)=0
-> enddo
-> do i=1,ntask_cont_to
-> ncont_sent(i)=0
-> enddo
-> c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
-> c & ntask_cont_to
-> C Make the list of contacts to send to send to other procesors
-> do i=iturn3_start,iturn3_end
-> c write (iout,*) "make contact list turn3",i," num_cont",
-> c & num_cont_hb(i)
-> call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
-> enddo
-> do i=iturn4_start,iturn4_end
-> c write (iout,*) "make contact list turn4",i," num_cont",
-> c & num_cont_hb(i)
-> call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
-> enddo
-> do ii=1,nat_sent
-> i=iat_sent(ii)
-> c write (iout,*) "make contact list longrange",i,ii," num_cont",
-> c & num_cont_hb(i)
-> do j=1,num_cont_hb(i)
-> do k=1,4
-> jjc=jcont_hb(j,i)
-> iproc=iint_sent_local(k,jjc,ii)
-> c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
-> if (iproc.ne.0) then
-> ncont_sent(iproc)=ncont_sent(iproc)+1
-> nn=ncont_sent(iproc)
-> zapas(1,nn,iproc)=i
-> zapas(2,nn,iproc)=jjc
-> zapas(3,nn,iproc)=d_cont(j,i)
-> ind=3
-> do kk=1,3
-> ind=ind+1
-> zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
-> enddo
-> do kk=1,2
-> do ll=1,2
-> ind=ind+1
-> zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
-> enddo
-> enddo
-> do jj=1,5
-> do kk=1,3
-> do ll=1,2
-> do mm=1,2
-> ind=ind+1
-> zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
-> enddo
-> enddo
-> enddo
-> enddo
-> endif
-> enddo
-> enddo
-> enddo
-> if (lprn) then
-> write (iout,*)
-> & "Numbers of contacts to be sent to other processors",
-> & (ncont_sent(i),i=1,ntask_cont_to)
-> write (iout,*) "Contacts sent"
-> do ii=1,ntask_cont_to
-> nn=ncont_sent(ii)
-> iproc=itask_cont_to(ii)
-> write (iout,*) nn," contacts to processor",iproc,
-> & " of CONT_TO_COMM group"
-> do i=1,nn
-> write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
-> enddo
-> enddo
-> call flush(iout)
-> endif
-4935,5023c6284,6403
-< CorrelID=MyID+1
-< ldone=.false.
-< do i=1,max_cont
-< do j=1,max_dim
-< buffer(i,j)=0.0D0
-< enddo
-< enddo
-< mm=mod(MyRank,2)
-< cd write (iout,*) 'MyRank',MyRank,' mm',mm
-< if (mm) 20,20,10
-< 10 continue
-< cd write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
-< if (MyRank.gt.0) then
-< C Send correlation contributions to the preceding processor
-< msglen=msglen1
-< nn=num_cont_hb(iatel_s)
-< call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
-< cd write (iout,*) 'The BUFFER array:'
-< cd do i=1,nn
-< cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
-< cd enddo
-< if (ielstart(iatel_s).gt.iatel_s+ispp) then
-< msglen=msglen2
-< call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
-< C Clear the contacts of the atom passed to the neighboring processor
-< nn=num_cont_hb(iatel_s+1)
-< cd do i=1,nn
-< cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
-< cd enddo
-< num_cont_hb(iatel_s)=0
-< endif
-< cd write (iout,*) 'Processor ',MyID,MyRank,
-< cd & ' is sending correlation contribution to processor',MyID-1,
-< cd & ' msglen=',msglen
-< cd write (*,*) 'Processor ',MyID,MyRank,
-< cd & ' is sending correlation contribution to processor',MyID-1,
-< cd & ' msglen=',msglen,' CorrelType=',CorrelType
-< call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
-< cd write (iout,*) 'Processor ',MyID,
-< cd & ' has sent correlation contribution to processor',MyID-1,
-< cd & ' msglen=',msglen,' CorrelID=',CorrelID
-< cd write (*,*) 'Processor ',MyID,
-< cd & ' has sent correlation contribution to processor',MyID-1,
-< cd & ' msglen=',msglen,' CorrelID=',CorrelID
-< msglen=msglen1
-< endif ! (MyRank.gt.0)
-< if (ldone) goto 30
-< ldone=.true.
-< 20 continue
-< cd write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
-< if (MyRank.lt.fgProcs-1) then
-< C Receive correlation contributions from the next processor
-< msglen=msglen1
-< if (ielend(iatel_e).lt.nct-1) msglen=msglen2
-< cd write (iout,*) 'Processor',MyID,
-< cd & ' is receiving correlation contribution from processor',MyID+1,
-< cd & ' msglen=',msglen,' CorrelType=',CorrelType
-< cd write (*,*) 'Processor',MyID,
-< cd & ' is receiving correlation contribution from processor',MyID+1,
-< cd & ' msglen=',msglen,' CorrelType=',CorrelType
-< nbytes=-1
-< do while (nbytes.le.0)
-< call mp_probe(MyID+1,CorrelType,nbytes)
-< enddo
-< cd print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
-< call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
-< cd write (iout,*) 'Processor',MyID,
-< cd & ' has received correlation contribution from processor',MyID+1,
-< cd & ' msglen=',msglen,' nbytes=',nbytes
-< cd write (iout,*) 'The received BUFFER array:'
-< cd do i=1,max_cont
-< cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
-< cd enddo
-< if (msglen.eq.msglen1) then
-< call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
-< else if (msglen.eq.msglen2) then
-< call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
-< call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
-< else
-< write (iout,*)
-< & 'ERROR!!!! message length changed while processing correlations.'
-< write (*,*)
-< & 'ERROR!!!! message length changed while processing correlations.'
-< call mp_stopall(Error)
-< endif ! msglen.eq.msglen1
-< endif ! MyRank.lt.fgProcs-1
-< if (ldone) goto 30
-< ldone=.true.
-< goto 10
----
-> CorrelID=fg_rank+1
-> CorrelType1=478
-> CorrelID1=nfgtasks+fg_rank+1
-> ireq=0
-> C Receive the numbers of needed contacts from other processors
-> do ii=1,ntask_cont_from
-> iproc=itask_cont_from(ii)
-> ireq=ireq+1
-> call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
-> & FG_COMM,req(ireq),IERR)
-> enddo
-> c write (iout,*) "IRECV ended"
-> c call flush(iout)
-> C Send the number of contacts needed by other processors
-> do ii=1,ntask_cont_to
-> iproc=itask_cont_to(ii)
-> ireq=ireq+1
-> call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
-> & FG_COMM,req(ireq),IERR)
-> enddo
-> c write (iout,*) "ISEND ended"
-> c write (iout,*) "number of requests (nn)",ireq
-> call flush(iout)
-> if (ireq.gt.0)
-> & call MPI_Waitall(ireq,req,status_array,ierr)
-> c write (iout,*)
-> c & "Numbers of contacts to be received from other processors",
-> c & (ncont_recv(i),i=1,ntask_cont_from)
-> c call flush(iout)
-> C Receive contacts
-> ireq=0
-> do ii=1,ntask_cont_from
-> iproc=itask_cont_from(ii)
-> nn=ncont_recv(ii)
-> c write (iout,*) "Receiving",nn," contacts from processor",iproc,
-> c & " of CONT_TO_COMM group"
-> call flush(iout)
-> if (nn.gt.0) then
-> ireq=ireq+1
-> call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
-> & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
-> c write (iout,*) "ireq,req",ireq,req(ireq)
-> endif
-> enddo
-> C Send the contacts to processors that need them
-> do ii=1,ntask_cont_to
-> iproc=itask_cont_to(ii)
-> nn=ncont_sent(ii)
-> c write (iout,*) nn," contacts to processor",iproc,
-> c & " of CONT_TO_COMM group"
-> if (nn.gt.0) then
-> ireq=ireq+1
-> call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
-> & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
-> c write (iout,*) "ireq,req",ireq,req(ireq)
-> c do i=1,nn
-> c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
-> c enddo
-> endif
-> enddo
-> c write (iout,*) "number of requests (contacts)",ireq
-> c write (iout,*) "req",(req(i),i=1,4)
-> c call flush(iout)
-> if (ireq.gt.0)
-> & call MPI_Waitall(ireq,req,status_array,ierr)
-> do iii=1,ntask_cont_from
-> iproc=itask_cont_from(iii)
-> nn=ncont_recv(iii)
-> if (lprn) then
-> write (iout,*) "Received",nn," contacts from processor",iproc,
-> & " of CONT_FROM_COMM group"
-> call flush(iout)
-> do i=1,nn
-> write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
-> enddo
-> call flush(iout)
-> endif
-> do i=1,nn
-> ii=zapas_recv(1,i,iii)
-> c Flag the received contacts to prevent double-counting
-> jj=-zapas_recv(2,i,iii)
-> c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
-> c call flush(iout)
-> nnn=num_cont_hb(ii)+1
-> num_cont_hb(ii)=nnn
-> jcont_hb(nnn,ii)=jj
-> d_cont(nnn,ii)=zapas_recv(3,i,iii)
-> ind=3
-> do kk=1,3
-> ind=ind+1
-> grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
-> enddo
-> do kk=1,2
-> do ll=1,2
-> ind=ind+1
-> a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
-> enddo
-> enddo
-> do jj=1,5
-> do kk=1,3
-> do ll=1,2
-> do mm=1,2
-> ind=ind+1
-> a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
-> enddo
-> enddo
-> enddo
-> enddo
-> enddo
-> enddo
-> call flush(iout)
-> if (lprn) then
-> write (iout,'(a)') 'Contact function values after receive:'
-> do i=nnt,nct-2
-> write (iout,'(2i3,50(1x,i3,5f6.3))')
-> & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
-> & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
-> enddo
-> call flush(iout)
-> endif
-5029,5031c6409,6411
-< write (iout,'(2i3,50(1x,i2,f5.2))')
-< & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
-< & j=1,num_cont_hb(i))
----
-> write (iout,'(2i3,50(1x,i2,5f6.3))')
-> & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
-> & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
-5049a6430
-> #ifdef MOMENT
-5050a6432
-> #endif
-5055c6437,6443
-< do i=iatel_s,iatel_e+1
----
-> c write (iout,*) "gradcorr5 in eello5 before loop"
-> c do iii=1,nres
-> c write (iout,'(i5,3f10.5)')
-> c & iii,(gradcorr5(jjj,iii),jjj=1,3)
-> c enddo
-> do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
-> c write (iout,*) "corr loop i",i
-5060a6449
-> jp=iabs(j)
-5063c6452,6453
-< c write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
----
-> jp1=iabs(j1)
-> c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
-5065c6455,6458
-< if (j1.eq.j+1 .or. j1.eq.j-1) then
----
-> c if (j1.eq.j+1 .or. j1.eq.j-1) then
-> if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
-> & .or. j.lt.0 .and. j1.gt.0) .and.
-> & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
-5075,5076c6468,6469
-< c write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
-< c & ' jj=',jj,' kk=',kk
----
-> cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
-> cd & ' jj=',jj,' kk=',kk
-5085,5086c6478,6483
-< cd & ' ekont=',ekont,' fprim=',fprimcont
-< call calc_eello(i,j,i+1,j1,jj,kk)
----
-> cd & ' ekont=',ekont,' fprim=',fprimcont,
-> cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
-> cd write (iout,*) "g_contij",g_contij
-> cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
-> cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
-> call calc_eello(i,jp,i+1,jp1,jj,kk)
-5088c6485,6493
-< & ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
----
-> & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
-> if (energy_dec.and.wcorr4.gt.0.0d0)
-> 1 write (iout,'(a6,4i5,0pf7.3)')
-> 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
-> c write (iout,*) "gradcorr5 before eello5"
-> c do iii=1,nres
-> c write (iout,'(i5,3f10.5)')
-> c & iii,(gradcorr5(jjj,iii),jjj=1,3)
-> c enddo
-5090,5091c6495,6503
-< & ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
-< c print *,"wcorr5",ecorr5
----
-> & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
-> c write (iout,*) "gradcorr5 after eello5"
-> c do iii=1,nres
-> c write (iout,'(i5,3f10.5)')
-> c & iii,(gradcorr5(jjj,iii),jjj=1,3)
-> c enddo
-> if (energy_dec.and.wcorr5.gt.0.0d0)
-> 1 write (iout,'(a6,4i5,0pf7.3)')
-> 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
-5093,5094c6505,6506
-< cd write(2,*)'ijkl',i,j,i+1,j1
-< if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
----
-> cd write(2,*)'ijkl',i,jp,i+1,jp1
-> if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
-5097c6509,6511
-< ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
----
-> ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
-> if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
-> 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
-5101,5103c6515,6517
-< cd & dabs(eello4(i,j,i+1,j1,jj,kk)),
-< cd & dabs(eello5(i,j,i+1,j1,jj,kk)),
-< cd & dabs(eello6(i,j,i+1,j1,jj,kk))
----
-> cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
-> cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
-> cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
-5105,5106c6519,6520
-< & .and. (j.eq.i+4 .and. j1.eq.i+3)) then
-< cd write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
----
-> & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
-> cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
-5107a6522,6523
-> if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
-> 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
-5112,5115d6527
-< else if (j1.eq.j) then
-< C Contacts I-J and I-(J+1) occur simultaneously.
-< C The system loses extra energy.
-< c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
-5118,5127d6529
-< do kk=1,num_conti
-< j1=jcont_hb(kk,i)
-< c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
-< c & ' jj=',jj,' kk=',kk
-< if (j1.eq.j+1) then
-< C Contacts I-J and (I+1)-J occur simultaneously.
-< C The system loses extra energy.
-< c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
-< endif ! j1==j+1
-< enddo ! kk
-5129a6532,6594
-> do i=1,nres
-> num_cont_hb(i)=num_cont_hb_old(i)
-> enddo
-> c write (iout,*) "gradcorr5 in eello5"
-> c do iii=1,nres
-> c write (iout,'(i5,3f10.5)')
-> c & iii,(gradcorr5(jjj,iii),jjj=1,3)
-> c enddo
-> return
-> end
-> c------------------------------------------------------------------------------
-> subroutine add_hb_contact_eello(ii,jj,itask)
-> implicit real*8 (a-h,o-z)
-> include "DIMENSIONS"
-> include "COMMON.IOUNITS"
-> integer max_cont
-> integer max_dim
-> parameter (max_cont=maxconts)
-> parameter (max_dim=70)
-> include "COMMON.CONTACTS"
-> double precision zapas(max_dim,maxconts,max_fg_procs),
-> & zapas_recv(max_dim,maxconts,max_fg_procs)
-> common /przechowalnia/ zapas
-> integer i,j,ii,jj,iproc,itask(4),nn
-> c write (iout,*) "itask",itask
-> do i=1,2
-> iproc=itask(i)
-> if (iproc.gt.0) then
-> do j=1,num_cont_hb(ii)
-> jjc=jcont_hb(j,ii)
-> c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
-> if (jjc.eq.jj) then
-> ncont_sent(iproc)=ncont_sent(iproc)+1
-> nn=ncont_sent(iproc)
-> zapas(1,nn,iproc)=ii
-> zapas(2,nn,iproc)=jjc
-> zapas(3,nn,iproc)=d_cont(j,ii)
-> ind=3
-> do kk=1,3
-> ind=ind+1
-> zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
-> enddo
-> do kk=1,2
-> do ll=1,2
-> ind=ind+1
-> zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
-> enddo
-> enddo
-> do jj=1,5
-> do kk=1,3
-> do ll=1,2
-> do mm=1,2
-> ind=ind+1
-> zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
-> enddo
-> enddo
-> enddo
-> enddo
-> exit
-> endif
-> enddo
-> endif
-> enddo
-5157,5161c6622,6626
-< c write (iout,*)'Contacts have occurred for peptide groups',i,j,
-< c & ' and',k,l
-< c write (iout,*)'Contacts have occurred for peptide groups',
-< c & i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
-< c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
----
-> c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
-> c & 'Contacts ',i,j,
-> c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
-> c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
-> c & 'gradcorr_long'
-5163,5164c6628
-< ecorr=ecorr+ekont*ees
-< if (calc_grad) then
----
-> c ecorr=ecorr+ekont*ees
-5165a6630,6633
-> coeffpees0pij=coeffp*ees0pij
-> coeffmees0mij=coeffm*ees0mij
-> coeffpees0pkl=coeffp*ees0pkl
-> coeffmees0mkl=coeffm*ees0mkl
-5167,5198c6635,6678
-< ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
-< gradcorr(ll,i)=gradcorr(ll,i)+ghalf
-< & -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
-< & coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
-< gradcorr(ll,j)=gradcorr(ll,j)+ghalf
-< & -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
-< & coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
-< ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
-< gradcorr(ll,k)=gradcorr(ll,k)+ghalf
-< & -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
-< & coeffm*ees0mij*gacontm_hb1(ll,kk,k))
-< gradcorr(ll,l)=gradcorr(ll,l)+ghalf
-< & -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
-< & coeffm*ees0mij*gacontm_hb2(ll,kk,k))
-< enddo
-< do m=i+1,j-1
-< do ll=1,3
-< gradcorr(ll,m)=gradcorr(ll,m)+
-< & ees*ekl*gacont_hbr(ll,jj,i)-
-< & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
-< & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
-< enddo
-< enddo
-< do m=k+1,l-1
-< do ll=1,3
-< gradcorr(ll,m)=gradcorr(ll,m)+
-< & ees*eij*gacont_hbr(ll,kk,k)-
-< & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
-< & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
-< enddo
-< enddo
-< endif
----
-> cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
-> gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
-> & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
-> & coeffmees0mkl*gacontm_hb1(ll,jj,i))
-> gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
-> & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
-> & coeffmees0mkl*gacontm_hb2(ll,jj,i))
-> cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
-> gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
-> & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
-> & coeffmees0mij*gacontm_hb1(ll,kk,k))
-> gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
-> & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
-> & coeffmees0mij*gacontm_hb2(ll,kk,k))
-> gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
-> & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
-> & coeffmees0mkl*gacontm_hb3(ll,jj,i))
-> gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
-> gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
-> gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
-> & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
-> & coeffmees0mij*gacontm_hb3(ll,kk,k))
-> gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
-> gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
-> c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
-> enddo
-> c write (iout,*)
-> cgrad do m=i+1,j-1
-> cgrad do ll=1,3
-> cgrad gradcorr(ll,m)=gradcorr(ll,m)+
-> cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
-> cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
-> cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
-> cgrad enddo
-> cgrad enddo
-> cgrad do m=k+1,l-1
-> cgrad do ll=1,3
-> cgrad gradcorr(ll,m)=gradcorr(ll,m)+
-> cgrad & ees*eij*gacont_hbr(ll,kk,k)-
-> cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
-> cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
-> cgrad enddo
-> cgrad enddo
-> c write (iout,*) "ehbcorr",ekont*ees
-5201a6682
-> #ifdef MOMENT
-5206d6686
-< include 'DIMENSIONS.ZSCOPT'
-5240d6719
-< if (.not.calc_grad) return
-5264a6744
-> #endif
-5273d6752
-< include 'DIMENSIONS.ZSCOPT'
-5289a6769,6770
-> cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
-> cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
-5650d7130
-< include 'DIMENSIONS.ZSCOPT'
-5671d7150
-< if (calc_grad) then
-5713,5718c7192,7197
-< cold ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
-< ggg1(ll)=eel4*g_contij(ll,1)
-< ggg2(ll)=eel4*g_contij(ll,2)
-< ghalf=0.5d0*ggg1(ll)
-< cd ghalf=0.0d0
-< gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
----
-> cgrad ggg1(ll)=eel4*g_contij(ll,1)
-> cgrad ggg2(ll)=eel4*g_contij(ll,2)
-> glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
-> glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
-> cgrad ghalf=0.5d0*ggg1(ll)
-> gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
-5720c7199
-< gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
----
-> gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
-5722,5725c7201,7204
-< cold ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
-< ghalf=0.5d0*ggg2(ll)
-< cd ghalf=0.0d0
-< gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
----
-> gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
-> gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
-> cgrad ghalf=0.5d0*ggg2(ll)
-> gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
-5727c7206
-< gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
----
-> gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
-5728a7208,7209
-> gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
-> gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
-5730,5753c7211,7230
-< cd goto 1112
-< do m=i+1,j-1
-< do ll=1,3
-< cold gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
-< gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
-< enddo
-< enddo
-< do m=k+1,l-1
-< do ll=1,3
-< cold gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
-< gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
-< enddo
-< enddo
-< 1112 continue
-< do m=i+2,j2
-< do ll=1,3
-< gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
-< enddo
-< enddo
-< do m=k+2,l2
-< do ll=1,3
-< gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
-< enddo
-< enddo
----
-> cgrad do m=i+1,j-1
-> cgrad do ll=1,3
-> cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
-> cgrad enddo
-> cgrad enddo
-> cgrad do m=k+1,l-1
-> cgrad do ll=1,3
-> cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
-> cgrad enddo
-> cgrad enddo
-> cgrad do m=i+2,j2
-> cgrad do ll=1,3
-> cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
-> cgrad enddo
-> cgrad enddo
-> cgrad do m=k+2,l2
-> cgrad do ll=1,3
-> cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
-> cgrad enddo
-> cgrad enddo
-5757d7233
-< endif
-5767d7242
-< include 'DIMENSIONS.ZSCOPT'
-5847d7321
-< if (calc_grad) then
-5886d7359
-< endif
-5895d7367
-< if (calc_grad) then
-5926d7397
-< endif
-5938d7408
-< if (calc_grad) then
-5971d7440
-< endif
-5980d7448
-< if (calc_grad) then
-6004d7471
-< endif
-6015d7481
-< if (calc_grad) then
-6048d7513
-< endif
-6057d7521
-< if (calc_grad) then
-6082d7545
-< endif
-6094d7556
-< if (calc_grad) then
-6112a7575,7578
-> C 2/11/08 AL Gradients over DC's connecting interacting sites will be
-> C summed up outside the subrouine as for the other subroutines
-> C handling long-range interactions. The old code is commented out
-> C with "cgrad" to keep track of changes.
-6114,6115c7580,7591
-< ggg1(ll)=eel5*g_contij(ll,1)
-< ggg2(ll)=eel5*g_contij(ll,2)
----
-> cgrad ggg1(ll)=eel5*g_contij(ll,1)
-> cgrad ggg2(ll)=eel5*g_contij(ll,2)
-> gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
-> gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
-> c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
-> c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
-> c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
-> c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
-> c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
-> c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
-> c & gradcorr5ij,
-> c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
-6117c7593
-< ghalf=0.5d0*ggg1(ll)
----
-> cgrad ghalf=0.5d0*ggg1(ll)
-6119c7595
-< gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
----
-> gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
-6121c7597
-< gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
----
-> gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
-6122a7599,7600
-> gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
-> gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
-6124c7602
-< ghalf=0.5d0*ggg2(ll)
----
-> cgrad ghalf=0.5d0*ggg2(ll)
-6129a7608,7609
-> gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
-> gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
-6132,6133c7612,7613
-< do m=i+1,j-1
-< do ll=1,3
----
-> cgrad do m=i+1,j-1
-> cgrad do ll=1,3
-6135,6139c7615,7619
-< gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
-< enddo
-< enddo
-< do m=k+1,l-1
-< do ll=1,3
----
-> cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
-> cgrad enddo
-> cgrad enddo
-> cgrad do m=k+1,l-1
-> cgrad do ll=1,3
-6141,6143c7621,7623
-< gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
-< enddo
-< enddo
----
-> cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
-> cgrad enddo
-> cgrad enddo
-6145,6154c7625,7634
-< do m=i+2,j2
-< do ll=1,3
-< gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
-< enddo
-< enddo
-< do m=k+2,l2
-< do ll=1,3
-< gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
-< enddo
-< enddo
----
-> cgrad do m=i+2,j2
-> cgrad do ll=1,3
-> cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
-> cgrad enddo
-> cgrad enddo
-> cgrad do m=k+2,l2
-> cgrad do ll=1,3
-> cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
-> cgrad enddo
-> cgrad enddo
-6158d7637
-< endif
-6168d7646
-< include 'DIMENSIONS.ZSCOPT'
-6228,6233c7706,7711
-< cd write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
-< cd write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
-< cd write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
-< cd write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
-< cd write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
-< cd write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
----
-> cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
-> cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
-> cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
-> cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
-> cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
-> cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
-6235d7712
-< if (calc_grad) then
-6251,6252c7728,7729
-< ggg1(ll)=eel6*g_contij(ll,1)
-< ggg2(ll)=eel6*g_contij(ll,2)
----
-> cgrad ggg1(ll)=eel6*g_contij(ll,1)
-> cgrad ggg2(ll)=eel6*g_contij(ll,2)
-6254c7731
-< ghalf=0.5d0*ggg1(ll)
----
-> cgrad ghalf=0.5d0*ggg1(ll)
-6256c7733,7735
-< gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
----
-> gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
-> gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
-> gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
-6258c7737
-< gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
----
-> gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
-6260c7739,7741
-< ghalf=0.5d0*ggg2(ll)
----
-> gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
-> gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
-> cgrad ghalf=0.5d0*ggg2(ll)
-6263c7744
-< gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
----
-> gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
-6265c7746
-< gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
----
-> gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
-6266a7748,7749
-> gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
-> gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
-6269,6270c7752,7753
-< do m=i+1,j-1
-< do ll=1,3
----
-> cgrad do m=i+1,j-1
-> cgrad do ll=1,3
-6272,6276c7755,7759
-< gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
-< enddo
-< enddo
-< do m=k+1,l-1
-< do ll=1,3
----
-> cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
-> cgrad enddo
-> cgrad enddo
-> cgrad do m=k+1,l-1
-> cgrad do ll=1,3
-6278,6291c7761,7774
-< gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
-< enddo
-< enddo
-< 1112 continue
-< do m=i+2,j2
-< do ll=1,3
-< gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
-< enddo
-< enddo
-< do m=k+2,l2
-< do ll=1,3
-< gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
-< enddo
-< enddo
----
-> cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
-> cgrad enddo
-> cgrad enddo
-> cgrad1112 continue
-> cgrad do m=i+2,j2
-> cgrad do ll=1,3
-> cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
-> cgrad enddo
-> cgrad enddo
-> cgrad do m=k+2,l2
-> cgrad do ll=1,3
-> cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
-> cgrad enddo
-> cgrad enddo
-6295d7777
-< endif
-6305d7786
-< include 'DIMENSIONS.ZSCOPT'
-6346d7826
-< if (.not. calc_grad) return
-6411d7890
-< include 'DIMENSIONS.ZSCOPT'
-6461d7939
-< if (.not. calc_grad) return
-6598d8075
-< include 'DIMENSIONS.ZSCOPT'
-6651c8128,8129
-< cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
----
-> cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
-> cd & "sum",-(s2+s3+s4)
-6658d8135
-< if (.not. calc_grad) return
-6714d8190
-< include 'DIMENSIONS.ZSCOPT'
-6794d8269
-< if (.not. calc_grad) return
-6960d8434
-< include 'DIMENSIONS.ZSCOPT'
-6975a8450,8453
-> s1=0.0d0
-> s8=0.0d0
-> s13=0.0d0
-> c
-7013,7014d8490
-< #else
-< s1 = 0.0d0
-7024,7025d8499
-< #else
-< s8=0.0d0
-7037,7038d8510
-< #else
-< s13=0.0d0
-7047d8518
-< if (calc_grad) then
-7048a8520,8521
-> s1d =0.0d0
-> s8d =0.0d0
-7056,7057d8528
-< #else
-< s8d=0.0d0
-7074,7075d8544
-< #else
-< s1d=0.0d0
-7089,7090d8557
-< #else
-< s13d=0.0d0
-7112,7113d8578
-< #else
-< s13d = 0.0d0
-7130,7131d8594
-< #else
-< s1d = 0.0d0
-7140,7141d8602
-< #else
-< s8d = 0.0d0
-7149,7150d8609
-< #else
-< s13d = 0.0d0
-7172,7173d8630
-< #else
-< s1d = 0.0d0
-7184,7185d8640
-< #else
-< s8d = 0.0d0
-7248,7250c8703,8705
-< ggg1(ll)=eel_turn6*g_contij(ll,1)
-< ggg2(ll)=eel_turn6*g_contij(ll,2)
-< ghalf=0.5d0*ggg1(ll)
----
-> cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
-> cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
-> cgrad ghalf=0.5d0*ggg1(ll)
-7252c8707,8709
-< gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
----
-> gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
-> gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
-> gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
-7255c8712
-< gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
----
-> gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
-7258c8715,8717
-< ghalf=0.5d0*ggg2(ll)
----
-> gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
-> gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
-> cgrad ghalf=0.5d0*ggg2(ll)
-7260c8719
-< gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
----
-> gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
-7263c8722
-< gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
----
-> gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
-7265a8725,8726
-> gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
-> gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
-7268,7288c8729,8749
-< do m=i+1,j-1
-< do ll=1,3
-< gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
-< enddo
-< enddo
-< do m=k+1,l-1
-< do ll=1,3
-< gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
-< enddo
-< enddo
-< 1112 continue
-< do m=i+2,j2
-< do ll=1,3
-< gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
-< enddo
-< enddo
-< do m=k+2,l2
-< do ll=1,3
-< gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
-< enddo
-< enddo
----
-> cgrad do m=i+1,j-1
-> cgrad do ll=1,3
-> cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
-> cgrad enddo
-> cgrad enddo
-> cgrad do m=k+1,l-1
-> cgrad do ll=1,3
-> cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
-> cgrad enddo
-> cgrad enddo
-> cgrad1112 continue
-> cgrad do m=i+2,j2
-> cgrad do ll=1,3
-> cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
-> cgrad enddo
-> cgrad enddo
-> cgrad do m=k+2,l2
-> cgrad do ll=1,3
-> cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
-> cgrad enddo
-> cgrad enddo
-7292d8752
-< endif
-7297a8758,8777
->
-> C-----------------------------------------------------------------------------
-> double precision function scalar(u,v)
-> !DIR$ INLINEALWAYS scalar
-> #ifndef OSF
-> cDEC$ ATTRIBUTES FORCEINLINE::scalar
-> #endif
-> implicit none
-> double precision u(3),v(3)
-> cd double precision sc
-> cd integer i
-> cd sc=0.0d0
-> cd do i=1,3
-> cd sc=sc+u(i)*v(i)
-> cd enddo
-> cd scalar=sc
->
-> scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
-> return
-> end
-7299a8780,8783
-> !DIR$ INLINEALWAYS MATVEC2
-> #ifndef OSF
-> cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
-> #endif
-7317a8802,8804
-> #ifndef OSF
-> cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
-> #endif
-7343a8831
-> !DIR$ INLINEALWAYS scalar2
-7354a8843,8846
-> !DIR$ INLINEALWAYS transpose2
-> #ifndef OSF
-> cDEC$ ATTRIBUTES FORCEINLINE::transpose2
-> #endif
-7376a8869,8872
-> !DIR$ INLINEALWAYS prodmat3
-> #ifndef OSF
-> cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
-> #endif
-7419,7431d8914
-< C-----------------------------------------------------------------------------
-< double precision function scalar(u,v)
-< implicit none
-< double precision u(3),v(3)
-< double precision sc
-< integer i
-< sc=0.0d0
-< do i=1,3
-< sc=sc+u(i)*v(i)
-< enddo
-< scalar=sc
-< return
-< end
+++ /dev/null
-# This make file is part of the xdrf package.
-#
-# (C) 1995 Frans van Hoesel, hoesel@chem.rug.nl
-#
-# 2006 modified by Cezary Czaplewski
-
-# Set C compiler and flags for ARCH
-BGLSYS = /bgl/BlueLight/ppcfloor/bglsys
-
-CC = xlc
-CPPC = xlc
-
-CFLAGS= -I. -O2 -qarch=440d -qtune=440
-
-M4 = m4
-M4FILE = RS6K.m4
-
-libxdrf.a: libxdrf.o ftocstr.o xdr_array.o xdr.o xdr_float.o xdr_stdio.o
- ar cr libxdrf.a $?
-
-clean:
- rm -f libxdrf.o ftocstr.o libxdrf.a
-
-ftocstr.o: ftocstr.c
- $(CC) $(CFLAGS) -c ftocstr.c
-
-libxdrf.o: libxdrf.m4 $(M4FILE)
- $(M4) $(M4FILE) libxdrf.m4 > libxdrf.c
- $(CC) $(CFLAGS) -c libxdrf.c
-# rm -f libxdrf.c
-
+++ /dev/null
-divert(-1)
-undefine(`len')
-#
-# do nothing special to FORTRAN function names
-#
-define(`FUNCTION',`$1')
-#
-# FORTRAN character strings are passed as follows:
-# a pointer to the base of the string is passed in the normal
-# argument list, and the length is passed by value as an extra
-# argument, after all of the other arguments.
-#
-define(`ARGS',`($1`'undivert(1))')
-define(`SAVE',`divert(1)$1`'divert(0)')
-define(`STRING_ARG',`$1_ptr`'SAVE(`, $1_len')')
-define(`STRING_ARG_DECL',`char * $1_ptr; int $1_len')
-define(`STRING_LEN',`$1_len')
-define(`STRING_PTR',`$1_ptr')
-divert(0)
-
+++ /dev/null
-/* Copyright (C) 1991-1993,1995-2003,2004,2005 Free Software Foundation, Inc.
- This file is part of the GNU C Library.
-
- The GNU C Library is free software; you can redistribute it and/or
- modify it under the terms of the GNU Lesser General Public
- License as published by the Free Software Foundation; either
- version 2.1 of the License, or (at your option) any later version.
-
- The GNU C Library is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- Lesser General Public License for more details.
-
- You should have received a copy of the GNU Lesser General Public
- License along with the GNU C Library; if not, write to the Free
- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
- 02111-1307 USA. */
-
-#ifndef _FEATURES_H
-#define _FEATURES_H 1
-
-/* These are defined by the user (or the compiler)
- to specify the desired environment:
-
- __STRICT_ANSI__ ISO Standard C.
- _ISOC99_SOURCE Extensions to ISO C89 from ISO C99.
- _POSIX_SOURCE IEEE Std 1003.1.
- _POSIX_C_SOURCE If ==1, like _POSIX_SOURCE; if >=2 add IEEE Std 1003.2;
- if >=199309L, add IEEE Std 1003.1b-1993;
- if >=199506L, add IEEE Std 1003.1c-1995;
- if >=200112L, all of IEEE 1003.1-2004
- _XOPEN_SOURCE Includes POSIX and XPG things. Set to 500 if
- Single Unix conformance is wanted, to 600 for the
- upcoming sixth revision.
- _XOPEN_SOURCE_EXTENDED XPG things and X/Open Unix extensions.
- _LARGEFILE_SOURCE Some more functions for correct standard I/O.
- _LARGEFILE64_SOURCE Additional functionality from LFS for large files.
- _FILE_OFFSET_BITS=N Select default filesystem interface.
- _BSD_SOURCE ISO C, POSIX, and 4.3BSD things.
- _SVID_SOURCE ISO C, POSIX, and SVID things.
- _GNU_SOURCE All of the above, plus GNU extensions.
- _REENTRANT Select additionally reentrant object.
- _THREAD_SAFE Same as _REENTRANT, often used by other systems.
- _FORTIFY_SOURCE If set to numeric value > 0 additional security
- measures are defined, according to level.
-
- The `-ansi' switch to the GNU C compiler defines __STRICT_ANSI__.
- If none of these are defined, the default is to have _SVID_SOURCE,
- _BSD_SOURCE, and _POSIX_SOURCE set to one and _POSIX_C_SOURCE set to
- 199506L. If more than one of these are defined, they accumulate.
- For example __STRICT_ANSI__, _POSIX_SOURCE and _POSIX_C_SOURCE
- together give you ISO C, 1003.1, and 1003.2, but nothing else.
-
- These are defined by this file and are used by the
- header files to decide what to declare or define:
-
- __USE_ISOC99 Define ISO C99 things.
- __USE_POSIX Define IEEE Std 1003.1 things.
- __USE_POSIX2 Define IEEE Std 1003.2 things.
- __USE_POSIX199309 Define IEEE Std 1003.1, and .1b things.
- __USE_POSIX199506 Define IEEE Std 1003.1, .1b, .1c and .1i things.
- __USE_XOPEN Define XPG things.
- __USE_XOPEN_EXTENDED Define X/Open Unix things.
- __USE_UNIX98 Define Single Unix V2 things.
- __USE_XOPEN2K Define XPG6 things.
- __USE_LARGEFILE Define correct standard I/O things.
- __USE_LARGEFILE64 Define LFS things with separate names.
- __USE_FILE_OFFSET64 Define 64bit interface as default.
- __USE_BSD Define 4.3BSD things.
- __USE_SVID Define SVID things.
- __USE_MISC Define things common to BSD and System V Unix.
- __USE_GNU Define GNU extensions.
- __USE_REENTRANT Define reentrant/thread-safe *_r functions.
- __USE_FORTIFY_LEVEL Additional security measures used, according to level.
- __FAVOR_BSD Favor 4.3BSD things in cases of conflict.
-
- The macros `__GNU_LIBRARY__', `__GLIBC__', and `__GLIBC_MINOR__' are
- defined by this file unconditionally. `__GNU_LIBRARY__' is provided
- only for compatibility. All new code should use the other symbols
- to test for features.
-
- All macros listed above as possibly being defined by this file are
- explicitly undefined if they are not explicitly defined.
- Feature-test macros that are not defined by the user or compiler
- but are implied by the other feature-test macros defined (or by the
- lack of any definitions) are defined by the file. */
-
-
-/* Undefine everything, so we get a clean slate. */
-#undef __USE_ISOC99
-#undef __USE_POSIX
-#undef __USE_POSIX2
-#undef __USE_POSIX199309
-#undef __USE_POSIX199506
-#undef __USE_XOPEN
-#undef __USE_XOPEN_EXTENDED
-#undef __USE_UNIX98
-#undef __USE_XOPEN2K
-#undef __USE_LARGEFILE
-#undef __USE_LARGEFILE64
-#undef __USE_FILE_OFFSET64
-#undef __USE_BSD
-#undef __USE_SVID
-#undef __USE_MISC
-#undef __USE_GNU
-#undef __USE_REENTRANT
-#undef __USE_FORTIFY_LEVEL
-#undef __FAVOR_BSD
-#undef __KERNEL_STRICT_NAMES
-
-/* Suppress kernel-name space pollution unless user expressedly asks
- for it. */
-#ifndef _LOOSE_KERNEL_NAMES
-# define __KERNEL_STRICT_NAMES
-#endif
-
-/* Always use ISO C things. */
-#define __USE_ANSI 1
-
-/* Convenience macros to test the versions of glibc and gcc.
- Use them like this:
- #if __GNUC_PREREQ (2,8)
- ... code requiring gcc 2.8 or later ...
- #endif
- Note - they won't work for gcc1 or glibc1, since the _MINOR macros
- were not defined then. */
-#if defined __GNUC__ && defined __GNUC_MINOR__
-# define __GNUC_PREREQ(maj, min) \
- ((__GNUC__ << 16) + __GNUC_MINOR__ >= ((maj) << 16) + (min))
-#else
-# define __GNUC_PREREQ(maj, min) 0
-#endif
-
-
-/* If _BSD_SOURCE was defined by the user, favor BSD over POSIX. */
-#if defined _BSD_SOURCE && \
- !(defined _POSIX_SOURCE || defined _POSIX_C_SOURCE || \
- defined _XOPEN_SOURCE || defined _XOPEN_SOURCE_EXTENDED || \
- defined _GNU_SOURCE || defined _SVID_SOURCE)
-# define __FAVOR_BSD 1
-#endif
-
-/* If _GNU_SOURCE was defined by the user, turn on all the other features. */
-#ifdef _GNU_SOURCE
-# undef _ISOC99_SOURCE
-# define _ISOC99_SOURCE 1
-# undef _POSIX_SOURCE
-# define _POSIX_SOURCE 1
-# undef _POSIX_C_SOURCE
-# define _POSIX_C_SOURCE 199506L
-# undef _XOPEN_SOURCE
-# define _XOPEN_SOURCE 600
-# undef _XOPEN_SOURCE_EXTENDED
-# define _XOPEN_SOURCE_EXTENDED 1
-# undef _LARGEFILE64_SOURCE
-# define _LARGEFILE64_SOURCE 1
-# undef _BSD_SOURCE
-# define _BSD_SOURCE 1
-# undef _SVID_SOURCE
-# define _SVID_SOURCE 1
-#endif
-
-/* If nothing (other than _GNU_SOURCE) is defined,
- define _BSD_SOURCE and _SVID_SOURCE. */
-#if (!defined __STRICT_ANSI__ && !defined _ISOC99_SOURCE && \
- !defined _POSIX_SOURCE && !defined _POSIX_C_SOURCE && \
- !defined _XOPEN_SOURCE && !defined _XOPEN_SOURCE_EXTENDED && \
- !defined _BSD_SOURCE && !defined _SVID_SOURCE)
-# define _BSD_SOURCE 1
-# define _SVID_SOURCE 1
-#endif
-
-/* This is to enable the ISO C99 extension. Also recognize the old macro
- which was used prior to the standard acceptance. This macro will
- eventually go away and the features enabled by default once the ISO C99
- standard is widely adopted. */
-#if (defined _ISOC99_SOURCE || defined _ISOC9X_SOURCE \
- || (defined __STDC_VERSION__ && __STDC_VERSION__ >= 199901L))
-# define __USE_ISOC99 1
-#endif
-
-/* If none of the ANSI/POSIX macros are defined, use POSIX.1 and POSIX.2
- (and IEEE Std 1003.1b-1993 unless _XOPEN_SOURCE is defined). */
-#if ((!defined __STRICT_ANSI__ || (_XOPEN_SOURCE - 0) >= 500) && \
- !defined _POSIX_SOURCE && !defined _POSIX_C_SOURCE)
-# define _POSIX_SOURCE 1
-# if defined _XOPEN_SOURCE && (_XOPEN_SOURCE - 0) < 500
-# define _POSIX_C_SOURCE 2
-# else
-# define _POSIX_C_SOURCE 199506L
-# endif
-#endif
-
-#if defined _POSIX_SOURCE || _POSIX_C_SOURCE >= 1 || defined _XOPEN_SOURCE
-# define __USE_POSIX 1
-#endif
-
-#if defined _POSIX_C_SOURCE && _POSIX_C_SOURCE >= 2 || defined _XOPEN_SOURCE
-# define __USE_POSIX2 1
-#endif
-
-#if (_POSIX_C_SOURCE - 0) >= 199309L
-# define __USE_POSIX199309 1
-#endif
-
-#if (_POSIX_C_SOURCE - 0) >= 199506L
-# define __USE_POSIX199506 1
-#endif
-
-#if (_POSIX_C_SOURCE - 0) >= 200112L
-# define __USE_XOPEN2K 1
-#endif
-
-#ifdef _XOPEN_SOURCE
-# define __USE_XOPEN 1
-# if (_XOPEN_SOURCE - 0) >= 500
-# define __USE_XOPEN_EXTENDED 1
-# define __USE_UNIX98 1
-# undef _LARGEFILE_SOURCE
-# define _LARGEFILE_SOURCE 1
-# if (_XOPEN_SOURCE - 0) >= 600
-# define __USE_XOPEN2K 1
-# undef __USE_ISOC99
-# define __USE_ISOC99 1
-# endif
-# else
-# ifdef _XOPEN_SOURCE_EXTENDED
-# define __USE_XOPEN_EXTENDED 1
-# endif
-# endif
-#endif
-
-#ifdef _LARGEFILE_SOURCE
-# define __USE_LARGEFILE 1
-#endif
-
-#ifdef _LARGEFILE64_SOURCE
-# define __USE_LARGEFILE64 1
-#endif
-
-#if defined _FILE_OFFSET_BITS && _FILE_OFFSET_BITS == 64
-# define __USE_FILE_OFFSET64 1
-#endif
-
-#if defined _BSD_SOURCE || defined _SVID_SOURCE
-# define __USE_MISC 1
-#endif
-
-#ifdef _BSD_SOURCE
-# define __USE_BSD 1
-#endif
-
-#ifdef _SVID_SOURCE
-# define __USE_SVID 1
-#endif
-
-#ifdef _GNU_SOURCE
-# define __USE_GNU 1
-#endif
-
-#if defined _REENTRANT || defined _THREAD_SAFE
-# define __USE_REENTRANT 1
-#endif
-
-#if _FORTIFY_SOURCE > 0 && __GNUC_PREREQ (4, 1) && __OPTIMIZE__ > 0
-# if _FORTIFY_SOURCE == 1
-# define __USE_FORTIFY_LEVEL 1
-# elif _FORTIFY_SOURCE > 1
-# define __USE_FORTIFY_LEVEL 2
-# endif
-#endif
-
-/* We do support the IEC 559 math functionality, real and complex. */
-#define __STDC_IEC_559__ 1
-#define __STDC_IEC_559_COMPLEX__ 1
-
-/* wchar_t uses ISO 10646-1 (2nd ed., published 2000-09-15) / Unicode 3.1. */
-#define __STDC_ISO_10646__ 200009L
-
-/* This macro indicates that the installed library is the GNU C Library.
- For historic reasons the value now is 6 and this will stay from now
- on. The use of this variable is deprecated. Use __GLIBC__ and
- __GLIBC_MINOR__ now (see below) when you want to test for a specific
- GNU C library version and use the values in <gnu/lib-names.h> to get
- the sonames of the shared libraries. */
-#undef __GNU_LIBRARY__
-#define __GNU_LIBRARY__ 6
-
-/* Major and minor version number of the GNU C library package. Use
- these macros to test for features in specific releases. */
-#define __GLIBC__ 2
-#define __GLIBC_MINOR__ 3
-
-#define __GLIBC_PREREQ(maj, min) \
- ((__GLIBC__ << 16) + __GLIBC_MINOR__ >= ((maj) << 16) + (min))
-
-/* Decide whether a compiler supports the long long datatypes. */
-#if defined __GNUC__ \
- || (defined __PGI && defined __i386__ ) \
- || (defined __INTEL_COMPILER && (defined __i386__ || defined __ia64__)) \
- || (defined __STDC_VERSION__ && __STDC_VERSION__ >= 199901L)
-# define __GLIBC_HAVE_LONG_LONG 1
-#endif
-
-/* This is here only because every header file already includes this one. */
-#ifndef __ASSEMBLER__
-# ifndef _SYS_CDEFS_H
-# include <sys/cdefs.h>
-# endif
-
-/* If we don't have __REDIRECT, prototypes will be missing if
- __USE_FILE_OFFSET64 but not __USE_LARGEFILE[64]. */
-# if defined __USE_FILE_OFFSET64 && !defined __REDIRECT
-# define __USE_LARGEFILE 1
-# define __USE_LARGEFILE64 1
-# endif
-
-#endif /* !ASSEMBLER */
-
-/* Decide whether we can define 'extern inline' functions in headers. */
-#if __GNUC_PREREQ (2, 7) && defined __OPTIMIZE__ \
- && !defined __OPTIMIZE_SIZE__ && !defined __NO_INLINE__
-# define __USE_EXTERN_INLINES 1
-#endif
-
-
-/* This is here only because every header file already includes this one.
- Get the definitions of all the appropriate `__stub_FUNCTION' symbols.
- <gnu/stubs.h> contains `#define __stub_FUNCTION' when FUNCTION is a stub
- that will always return failure (and set errno to ENOSYS). */
-#include <gnu/stubs.h>
-
-
-#endif /* features.h */
+++ /dev/null
-
-
-int ftocstr(ds, dl, ss, sl)
- char *ds, *ss; /* dst, src ptrs */
- int dl; /* dst max len */
- int sl; /* src len */
-{
- char *p;
-
- for (p = ss + sl; --p >= ss && *p == ' '; ) ;
- sl = p - ss + 1;
- dl--;
- ds[0] = 0;
- if (sl > dl)
- return 1;
- while (sl--)
- (*ds++ = *ss++);
- *ds = '\0';
- return 0;
-}
-
-
-int ctofstr(ds, dl, ss)
- char *ds; /* dest space */
- int dl; /* max dest length */
- char *ss; /* src string (0-term) */
-{
- while (dl && *ss) {
- *ds++ = *ss++;
- dl--;
- }
- while (dl--)
- *ds++ = ' ';
- return 0;
-}
+++ /dev/null
-
-
-/*____________________________________________________________________________
- |
- | libxdrf - portable fortran interface to xdr. some xdr routines
- | are C routines for compressed coordinates
- |
- | version 1.1
- |
- | This collection of routines is intended to write and read
- | data in a portable way to a file, so data written on one type
- | of machine can be read back on a different type.
- |
- | all fortran routines use an integer 'xdrid', which is an id to the
- | current xdr file, and is set by xdrfopen.
- | most routines have in integer 'ret' which is the return value.
- | The value of 'ret' is zero on failure, and most of the time one
- | on succes.
- |
- | There are three routines useful for C users:
- | xdropen(), xdrclose(), xdr3dfcoord().
- | The first two replace xdrstdio_create and xdr_destroy, and *must* be
- | used when you plan to use xdr3dfcoord(). (they are also a bit
- | easier to interface). For writing data other than compressed coordinates
- | you should use the standard C xdr routines (see xdr man page)
- |
- | xdrfopen(xdrid, filename, mode, ret)
- | character *(*) filename
- | character *(*) mode
- |
- | this will open the file with the given filename (string)
- | and the given mode, it returns an id in xdrid, which is
- | to be used in all other calls to xdrf routines.
- | mode is 'w' to create, or update an file, for all other
- | values of mode the file is opened for reading
- |
- | you need to call xdrfclose to flush the output and close
- | the file.
- | Note that you should not use xdrstdio_create, which comes with the
- | standard xdr library
- |
- | xdrfclose(xdrid, ret)
- | flush the data to the file, and closes the file;
- | You should not use xdr_destroy (which comes standard with
- | the xdr libraries.
- |
- | xdrfbool(xdrid, bp, ret)
- | integer pb
- |
- | This filter produces values of either 1 or 0
- |
- | xdrfchar(xdrid, cp, ret)
- | character cp
- |
- | filter that translate between characters and their xdr representation
- | Note that the characters in not compressed and occupies 4 bytes.
- |
- | xdrfdouble(xdrid, dp, ret)
- | double dp
- |
- | read/write a double.
- |
- | xdrffloat(xdrid, fp, ret)
- | float fp
- |
- | read/write a float.
- |
- | xdrfint(xdrid, ip, ret)
- | integer ip
- |
- | read/write integer.
- |
- | xdrflong(xdrid, lp, ret)
- | integer lp
- |
- | this routine has a possible portablility problem due to 64 bits longs.
- |
- | xdrfshort(xdrid, sp, ret)
- | integer *2 sp
- |
- | xdrfstring(xdrid, sp, maxsize, ret)
- | character *(*)
- | integer maxsize
- |
- | read/write a string, with maximum length given by maxsize
- |
- | xdrfwrapstring(xdris, sp, ret)
- | character *(*)
- |
- | read/write a string (it is the same as xdrfstring accept that it finds
- | the stringlength itself.
- |
- | xdrfvector(xdrid, cp, size, xdrfproc, ret)
- | character *(*)
- | integer size
- | external xdrfproc
- |
- | read/write an array pointed to by cp, with number of elements
- | defined by 'size'. the routine 'xdrfproc' is the name
- | of one of the above routines to read/write data (like xdrfdouble)
- | In contrast with the c-version you don't need to specify the
- | byte size of an element.
- | xdrfstring is not allowed here (it is in the c version)
- |
- | xdrf3dfcoord(xdrid, fp, size, precision, ret)
- | real (*) fp
- | real precision
- | integer size
- |
- | this is *NOT* a standard xdr routine. I named it this way, because
- | it invites people to use the other xdr routines.
- | It is introduced to store specifically 3d coordinates of molecules
- | (as found in molecular dynamics) and it writes it in a compressed way.
- | It starts by multiplying all numbers by precision and
- | rounding the result to integer. effectively converting
- | all floating point numbers to fixed point.
- | it uses an algorithm for compression that is optimized for
- | molecular data, but could be used for other 3d coordinates
- | as well. There is subtantial overhead involved, so call this
- | routine only if you have a large number of coordinates to read/write
- |
- | ________________________________________________________________________
- |
- | Below are the routines to be used by C programmers. Use the 'normal'
- | xdr routines to write integers, floats, etc (see man xdr)
- |
- | int xdropen(XDR *xdrs, const char *filename, const char *type)
- | This will open the file with the given filename and the
- | given mode. You should pass it an allocated XDR struct
- | in xdrs, to be used in all other calls to xdr routines.
- | Mode is 'w' to create, or update an file, and for all
- | other values of mode the file is opened for reading.
- | You need to call xdrclose to flush the output and close
- | the file.
- |
- | Note that you should not use xdrstdio_create, which
- | comes with the standard xdr library.
- |
- | int xdrclose(XDR *xdrs)
- | Flush the data to the file, and close the file;
- | You should not use xdr_destroy (which comes standard
- | with the xdr libraries).
- |
- | int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision)
- | This is \fInot\fR a standard xdr routine. I named it this
- | way, because it invites people to use the other xdr
- | routines.
- |
- | (c) 1995 Frans van Hoesel, hoesel@chem.rug.nl
-*/
-
-
-#include <limits.h>
-#include <malloc.h>
-#include <math.h>
-/* #include <rpc/rpc.h>
-#include <rpc/xdr.h> */
-#include "xdr.h"
-#include <stdio.h>
-#include <stdlib.h>
-#include "xdrf.h"
-
-int ftocstr(char *, int, char *, int);
-int ctofstr(char *, int, char *);
-
-#define MAXID 20
-static FILE *xdrfiles[MAXID];
-static XDR *xdridptr[MAXID];
-static char xdrmodes[MAXID];
-static unsigned int cnt;
-
-typedef void (* xdrfproc) (int *, void *, int *);
-
-void
-xdrfbool (xdrid, pb, ret)
-int *xdrid, *ret;
-int *pb;
-{
- *ret = xdr_bool(xdridptr[*xdrid], (bool_t *) pb);
- cnt += sizeof(int);
-}
-
-void
-xdrfchar (xdrid, cp, ret)
-int *xdrid, *ret;
-char *cp;
-{
- *ret = xdr_char(xdridptr[*xdrid], cp);
- cnt += sizeof(char);
-}
-
-void
-xdrfdouble (xdrid, dp, ret)
-int *xdrid, *ret;
-double *dp;
-{
- *ret = xdr_double(xdridptr[*xdrid], dp);
- cnt += sizeof(double);
-}
-
-void
-xdrffloat (xdrid, fp, ret)
-int *xdrid, *ret;
-float *fp;
-{
- *ret = xdr_float(xdridptr[*xdrid], fp);
- cnt += sizeof(float);
-}
-
-void
-xdrfint (xdrid, ip, ret)
-int *xdrid, *ret;
-int *ip;
-{
- *ret = xdr_int(xdridptr[*xdrid], ip);
- cnt += sizeof(int);
-}
-
-void
-xdrflong (xdrid, lp, ret)
-int *xdrid, *ret;
-long *lp;
-{
- *ret = xdr_long(xdridptr[*xdrid], lp);
- cnt += sizeof(long);
-}
-
-void
-xdrfshort (xdrid, sp, ret)
-int *xdrid, *ret;
-short *sp;
-{
- *ret = xdr_short(xdridptr[*xdrid], sp);
- cnt += sizeof(sp);
-}
-
-void
-xdrfuchar (xdrid, ucp, ret)
-int *xdrid, *ret;
-char *ucp;
-{
- *ret = xdr_u_char(xdridptr[*xdrid], ucp);
- cnt += sizeof(char);
-}
-
-void
-xdrfulong (xdrid, ulp, ret)
-int *xdrid, *ret;
-unsigned long *ulp;
-{
- *ret = xdr_u_long(xdridptr[*xdrid], ulp);
- cnt += sizeof(unsigned long);
-}
-
-void
-xdrfushort (xdrid, usp, ret)
-int *xdrid, *ret;
-unsigned short *usp;
-{
- *ret = xdr_u_short(xdridptr[*xdrid], usp);
- cnt += sizeof(unsigned short);
-}
-
-void
-xdrf3dfcoord (xdrid, fp, size, precision, ret)
-int *xdrid, *ret;
-float *fp;
-int *size;
-float *precision;
-{
- *ret = xdr3dfcoord(xdridptr[*xdrid], fp, size, precision);
-}
-
-void
-xdrfstring (xdrid, sp_ptr, maxsize, ret, sp_len)
-int *xdrid, *ret;
-char * sp_ptr; int sp_len;
-int *maxsize;
-{
- char *tsp;
-
- tsp = (char*) malloc(((sp_len) + 1) * sizeof(char));
- if (tsp == NULL) {
- *ret = -1;
- return;
- }
- if (ftocstr(tsp, *maxsize+1, sp_ptr, sp_len)) {
- *ret = -1;
- free(tsp);
- return;
- }
- *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int) *maxsize);
- ctofstr( sp_ptr, sp_len, tsp);
- cnt += *maxsize;
- free(tsp);
-}
-
-void
-xdrfwrapstring (xdrid, sp_ptr, ret, sp_len)
-int *xdrid, *ret;
-char * sp_ptr; int sp_len;
-{
- char *tsp;
- int maxsize;
- maxsize = (sp_len) + 1;
- tsp = (char*) malloc(maxsize * sizeof(char));
- if (tsp == NULL) {
- *ret = -1;
- return;
- }
- if (ftocstr(tsp, maxsize, sp_ptr, sp_len)) {
- *ret = -1;
- free(tsp);
- return;
- }
- *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int)maxsize);
- ctofstr( sp_ptr, sp_len, tsp);
- cnt += maxsize;
- free(tsp);
-}
-
-void
-xdrfopaque (xdrid, cp, ccnt, ret)
-int *xdrid, *ret;
-caddr_t *cp;
-int *ccnt;
-{
- *ret = xdr_opaque(xdridptr[*xdrid], (caddr_t)*cp, (u_int)*ccnt);
- cnt += *ccnt;
-}
-
-void
-xdrfsetpos (xdrid, pos, ret)
-int *xdrid, *ret;
-int *pos;
-{
- *ret = xdr_setpos(xdridptr[*xdrid], (u_int) *pos);
-}
-
-void
-xdrf (xdrid, pos)
-int *xdrid, *pos;
-{
- *pos = xdr_getpos(xdridptr[*xdrid]);
-}
-
-void
-xdrfvector (xdrid, cp, size, elproc, ret)
-int *xdrid, *ret;
-char *cp;
-int *size;
-xdrfproc elproc;
-{
- int lcnt;
- cnt = 0;
- for (lcnt = 0; lcnt < *size; lcnt++) {
- elproc(xdrid, (cp+cnt) , ret);
- }
-}
-
-
-void
-xdrfclose (xdrid, ret)
-int *xdrid;
-int *ret;
-{
- *ret = xdrclose(xdridptr[*xdrid]);
- cnt = 0;
-}
-
-void
-xdrfopen (xdrid, fp_ptr, mode_ptr, ret, fp_len, mode_len)
-int *xdrid;
-char * fp_ptr; int fp_len;
-char * mode_ptr; int mode_len;
-int *ret;
-{
- char fname[512];
- char fmode[3];
-
- if (ftocstr(fname, sizeof(fname), fp_ptr, fp_len)) {
- *ret = 0;
- }
- if (ftocstr(fmode, sizeof(fmode), mode_ptr,
- mode_len)) {
- *ret = 0;
- }
-
- *xdrid = xdropen(NULL, fname, fmode);
- if (*xdrid == 0)
- *ret = 0;
- else
- *ret = 1;
-}
-
-/*___________________________________________________________________________
- |
- | what follows are the C routines for opening, closing xdr streams
- | and the routine to read/write compressed coordinates together
- | with some routines to assist in this task (those are marked
- | static and cannot be called from user programs)
-*/
-#define MAXABS INT_MAX-2
-
-#ifndef MIN
-#define MIN(x,y) ((x) < (y) ? (x):(y))
-#endif
-#ifndef MAX
-#define MAX(x,y) ((x) > (y) ? (x):(y))
-#endif
-#ifndef SQR
-#define SQR(x) ((x)*(x))
-#endif
-static int magicints[] = {
- 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 8, 10, 12, 16, 20, 25, 32, 40, 50, 64,
- 80, 101, 128, 161, 203, 256, 322, 406, 512, 645,
- 812, 1024, 1290, 1625, 2048, 2580, 3250, 4096, 5060, 6501,
- 8192, 10321, 13003, 16384, 20642, 26007, 32768, 41285, 52015, 65536,
- 82570, 104031, 131072, 165140, 208063, 262144, 330280, 416127, 524287, 660561,
- 832255, 1048576, 1321122, 1664510, 2097152, 2642245, 3329021, 4194304, 5284491, 6658042,
- 8388607, 10568983, 13316085, 16777216 };
-
-#define FIRSTIDX 9
-/* note that magicints[FIRSTIDX-1] == 0 */
-#define LASTIDX (sizeof(magicints) / sizeof(*magicints))
-
-
-/*__________________________________________________________________________
- |
- | xdropen - open xdr file
- |
- | This versions differs from xdrstdio_create, because I need to know
- | the state of the file (read or write) so I can use xdr3dfcoord
- | in eigther read or write mode, and the file descriptor
- | so I can close the file (something xdr_destroy doesn't do).
- |
-*/
-
-int xdropen(XDR *xdrs, const char *filename, const char *type) {
- static int init_done = 0;
- enum xdr_op lmode;
- const char *type1;
- int xdrid;
-
- if (init_done == 0) {
- for (xdrid = 1; xdrid < MAXID; xdrid++) {
- xdridptr[xdrid] = NULL;
- }
- init_done = 1;
- }
- xdrid = 1;
- while (xdrid < MAXID && xdridptr[xdrid] != NULL) {
- xdrid++;
- }
- if (xdrid == MAXID) {
- return 0;
- }
- if (*type == 'w' || *type == 'W') {
- type = "w+";
- type1 = "a+";
- lmode = XDR_ENCODE;
- } else {
- type = "r";
- type1 = "r";
- lmode = XDR_DECODE;
- }
- xdrfiles[xdrid] = fopen(filename, type1);
- if (xdrfiles[xdrid] == NULL) {
- xdrs = NULL;
- return 0;
- }
- xdrmodes[xdrid] = *type;
- /* next test isn't usefull in the case of C language
- * but is used for the Fortran interface
- * (C users are expected to pass the address of an already allocated
- * XDR staructure)
- */
- if (xdrs == NULL) {
- xdridptr[xdrid] = (XDR *) malloc(sizeof(XDR));
- xdrstdio_create(xdridptr[xdrid], xdrfiles[xdrid], lmode);
- } else {
- xdridptr[xdrid] = xdrs;
- xdrstdio_create(xdrs, xdrfiles[xdrid], lmode);
- }
- return xdrid;
-}
-
-/*_________________________________________________________________________
- |
- | xdrclose - close a xdr file
- |
- | This will flush the xdr buffers, and destroy the xdr stream.
- | It also closes the associated file descriptor (this is *not*
- | done by xdr_destroy).
- |
-*/
-
-int xdrclose(XDR *xdrs) {
- int xdrid;
-
- if (xdrs == NULL) {
- fprintf(stderr, "xdrclose: passed a NULL pointer\n");
- exit(1);
- }
- for (xdrid = 1; xdrid < MAXID; xdrid++) {
- if (xdridptr[xdrid] == xdrs) {
-
- xdr_destroy(xdrs);
- fclose(xdrfiles[xdrid]);
- xdridptr[xdrid] = NULL;
- return 1;
- }
- }
- fprintf(stderr, "xdrclose: no such open xdr file\n");
- exit(1);
-
-}
-
-/*____________________________________________________________________________
- |
- | sendbits - encode num into buf using the specified number of bits
- |
- | This routines appends the value of num to the bits already present in
- | the array buf. You need to give it the number of bits to use and you
- | better make sure that this number of bits is enough to hold the value
- | Also num must be positive.
- |
-*/
-
-static void sendbits(int buf[], int num_of_bits, int num) {
-
- unsigned int cnt, lastbyte;
- int lastbits;
- unsigned char * cbuf;
-
- cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf);
- cnt = (unsigned int) buf[0];
- lastbits = buf[1];
- lastbyte =(unsigned int) buf[2];
- while (num_of_bits >= 8) {
- lastbyte = (lastbyte << 8) | ((num >> (num_of_bits -8)) /* & 0xff*/);
- cbuf[cnt++] = lastbyte >> lastbits;
- num_of_bits -= 8;
- }
- if (num_of_bits > 0) {
- lastbyte = (lastbyte << num_of_bits) | num;
- lastbits += num_of_bits;
- if (lastbits >= 8) {
- lastbits -= 8;
- cbuf[cnt++] = lastbyte >> lastbits;
- }
- }
- buf[0] = cnt;
- buf[1] = lastbits;
- buf[2] = lastbyte;
- if (lastbits>0) {
- cbuf[cnt] = lastbyte << (8 - lastbits);
- }
-}
-
-/*_________________________________________________________________________
- |
- | sizeofint - calculate bitsize of an integer
- |
- | return the number of bits needed to store an integer with given max size
- |
-*/
-
-static int sizeofint(const int size) {
- unsigned int num = 1;
- int num_of_bits = 0;
-
- while (size >= num && num_of_bits < 32) {
- num_of_bits++;
- num <<= 1;
- }
- return num_of_bits;
-}
-
-/*___________________________________________________________________________
- |
- | sizeofints - calculate 'bitsize' of compressed ints
- |
- | given the number of small unsigned integers and the maximum value
- | return the number of bits needed to read or write them with the
- | routines receiveints and sendints. You need this parameter when
- | calling these routines. Note that for many calls I can use
- | the variable 'smallidx' which is exactly the number of bits, and
- | So I don't need to call 'sizeofints for those calls.
-*/
-
-static int sizeofints( const int num_of_ints, unsigned int sizes[]) {
- int i, num;
- unsigned int num_of_bytes, num_of_bits, bytes[32], bytecnt, tmp;
- num_of_bytes = 1;
- bytes[0] = 1;
- num_of_bits = 0;
- for (i=0; i < num_of_ints; i++) {
- tmp = 0;
- for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) {
- tmp = bytes[bytecnt] * sizes[i] + tmp;
- bytes[bytecnt] = tmp & 0xff;
- tmp >>= 8;
- }
- while (tmp != 0) {
- bytes[bytecnt++] = tmp & 0xff;
- tmp >>= 8;
- }
- num_of_bytes = bytecnt;
- }
- num = 1;
- num_of_bytes--;
- while (bytes[num_of_bytes] >= num) {
- num_of_bits++;
- num *= 2;
- }
- return num_of_bits + num_of_bytes * 8;
-
-}
-
-/*____________________________________________________________________________
- |
- | sendints - send a small set of small integers in compressed format
- |
- | this routine is used internally by xdr3dfcoord, to send a set of
- | small integers to the buffer.
- | Multiplication with fixed (specified maximum ) sizes is used to get
- | to one big, multibyte integer. Allthough the routine could be
- | modified to handle sizes bigger than 16777216, or more than just
- | a few integers, this is not done, because the gain in compression
- | isn't worth the effort. Note that overflowing the multiplication
- | or the byte buffer (32 bytes) is unchecked and causes bad results.
- |
- */
-
-static void sendints(int buf[], const int num_of_ints, const int num_of_bits,
- unsigned int sizes[], unsigned int nums[]) {
-
- int i;
- unsigned int bytes[32], num_of_bytes, bytecnt, tmp;
-
- tmp = nums[0];
- num_of_bytes = 0;
- do {
- bytes[num_of_bytes++] = tmp & 0xff;
- tmp >>= 8;
- } while (tmp != 0);
-
- for (i = 1; i < num_of_ints; i++) {
- if (nums[i] >= sizes[i]) {
- fprintf(stderr,"major breakdown in sendints num %d doesn't "
- "match size %d\n", nums[i], sizes[i]);
- exit(1);
- }
- /* use one step multiply */
- tmp = nums[i];
- for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) {
- tmp = bytes[bytecnt] * sizes[i] + tmp;
- bytes[bytecnt] = tmp & 0xff;
- tmp >>= 8;
- }
- while (tmp != 0) {
- bytes[bytecnt++] = tmp & 0xff;
- tmp >>= 8;
- }
- num_of_bytes = bytecnt;
- }
- if (num_of_bits >= num_of_bytes * 8) {
- for (i = 0; i < num_of_bytes; i++) {
- sendbits(buf, 8, bytes[i]);
- }
- sendbits(buf, num_of_bits - num_of_bytes * 8, 0);
- } else {
- for (i = 0; i < num_of_bytes-1; i++) {
- sendbits(buf, 8, bytes[i]);
- }
- sendbits(buf, num_of_bits- (num_of_bytes -1) * 8, bytes[i]);
- }
-}
-
-
-/*___________________________________________________________________________
- |
- | receivebits - decode number from buf using specified number of bits
- |
- | extract the number of bits from the array buf and construct an integer
- | from it. Return that value.
- |
-*/
-
-static int receivebits(int buf[], int num_of_bits) {
-
- int cnt, num;
- unsigned int lastbits, lastbyte;
- unsigned char * cbuf;
- int mask = (1 << num_of_bits) -1;
-
- cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf);
- cnt = buf[0];
- lastbits = (unsigned int) buf[1];
- lastbyte = (unsigned int) buf[2];
-
- num = 0;
- while (num_of_bits >= 8) {
- lastbyte = ( lastbyte << 8 ) | cbuf[cnt++];
- num |= (lastbyte >> lastbits) << (num_of_bits - 8);
- num_of_bits -=8;
- }
- if (num_of_bits > 0) {
- if (lastbits < num_of_bits) {
- lastbits += 8;
- lastbyte = (lastbyte << 8) | cbuf[cnt++];
- }
- lastbits -= num_of_bits;
- num |= (lastbyte >> lastbits) & ((1 << num_of_bits) -1);
- }
- num &= mask;
- buf[0] = cnt;
- buf[1] = lastbits;
- buf[2] = lastbyte;
- return num;
-}
-
-/*____________________________________________________________________________
- |
- | receiveints - decode 'small' integers from the buf array
- |
- | this routine is the inverse from sendints() and decodes the small integers
- | written to buf by calculating the remainder and doing divisions with
- | the given sizes[]. You need to specify the total number of bits to be
- | used from buf in num_of_bits.
- |
-*/
-
-static void receiveints(int buf[], const int num_of_ints, int num_of_bits,
- unsigned int sizes[], int nums[]) {
- int bytes[32];
- int i, j, num_of_bytes, p, num;
-
- bytes[1] = bytes[2] = bytes[3] = 0;
- num_of_bytes = 0;
- while (num_of_bits > 8) {
- bytes[num_of_bytes++] = receivebits(buf, 8);
- num_of_bits -= 8;
- }
- if (num_of_bits > 0) {
- bytes[num_of_bytes++] = receivebits(buf, num_of_bits);
- }
- for (i = num_of_ints-1; i > 0; i--) {
- num = 0;
- for (j = num_of_bytes-1; j >=0; j--) {
- num = (num << 8) | bytes[j];
- p = num / sizes[i];
- bytes[j] = p;
- num = num - p * sizes[i];
- }
- nums[i] = num;
- }
- nums[0] = bytes[0] | (bytes[1] << 8) | (bytes[2] << 16) | (bytes[3] << 24);
-}
-
-/*____________________________________________________________________________
- |
- | xdr3dfcoord - read or write compressed 3d coordinates to xdr file.
- |
- | this routine reads or writes (depending on how you opened the file with
- | xdropen() ) a large number of 3d coordinates (stored in *fp).
- | The number of coordinates triplets to write is given by *size. On
- | read this number may be zero, in which case it reads as many as were written
- | or it may specify the number if triplets to read (which should match the
- | number written).
- | Compression is achieved by first converting all floating numbers to integer
- | using multiplication by *precision and rounding to the nearest integer.
- | Then the minimum and maximum value are calculated to determine the range.
- | The limited range of integers so found, is used to compress the coordinates.
- | In addition the differences between succesive coordinates is calculated.
- | If the difference happens to be 'small' then only the difference is saved,
- | compressing the data even more. The notion of 'small' is changed dynamically
- | and is enlarged or reduced whenever needed or possible.
- | Extra compression is achieved in the case of GROMOS and coordinates of
- | water molecules. GROMOS first writes out the Oxygen position, followed by
- | the two hydrogens. In order to make the differences smaller (and thereby
- | compression the data better) the order is changed into first one hydrogen
- | then the oxygen, followed by the other hydrogen. This is rather special, but
- | it shouldn't harm in the general case.
- |
- */
-
-int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) {
-
-
- static int *ip = NULL;
- static int oldsize;
- static int *buf;
-
- int minint[3], maxint[3], mindiff, *lip, diff;
- int lint1, lint2, lint3, oldlint1, oldlint2, oldlint3, smallidx;
- int minidx, maxidx;
- unsigned sizeint[3], sizesmall[3], bitsizeint[3], size3, *luip;
- int flag, k;
- int small, smaller, larger, i, is_small, is_smaller, run, prevrun;
- float *lfp, lf;
- int tmp, *thiscoord, prevcoord[3];
- unsigned int tmpcoord[30];
-
- int bufsize, xdrid, lsize;
- unsigned int bitsize;
- float inv_precision;
- int errval = 1;
-
- /* find out if xdrs is opened for reading or for writing */
- xdrid = 0;
- while (xdridptr[xdrid] != xdrs) {
- xdrid++;
- if (xdrid >= MAXID) {
- fprintf(stderr, "xdr error. no open xdr stream\n");
- exit (1);
- }
- }
- if (xdrmodes[xdrid] == 'w') {
-
- /* xdrs is open for writing */
-
- if (xdr_int(xdrs, size) == 0)
- return 0;
- size3 = *size * 3;
- /* when the number of coordinates is small, don't try to compress; just
- * write them as floats using xdr_vector
- */
- if (*size <= 9 ) {
- return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp),
- (xdrproc_t)xdr_float));
- }
-
- xdr_float(xdrs, precision);
- if (ip == NULL) {
- ip = (int *)malloc(size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)malloc(bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- } else if (*size > oldsize) {
- ip = (int *)realloc(ip, size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)realloc(buf, bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- }
- /* buf[0-2] are special and do not contain actual data */
- buf[0] = buf[1] = buf[2] = 0;
- minint[0] = minint[1] = minint[2] = INT_MAX;
- maxint[0] = maxint[1] = maxint[2] = INT_MIN;
- prevrun = -1;
- lfp = fp;
- lip = ip;
- mindiff = INT_MAX;
- oldlint1 = oldlint2 = oldlint3 = 0;
- while(lfp < fp + size3 ) {
- /* find nearest integer */
- if (*lfp >= 0.0)
- lf = *lfp * *precision + 0.5;
- else
- lf = *lfp * *precision - 0.5;
- if (fabs(lf) > MAXABS) {
- /* scaling would cause overflow */
- errval = 0;
- }
- lint1 = lf;
- if (lint1 < minint[0]) minint[0] = lint1;
- if (lint1 > maxint[0]) maxint[0] = lint1;
- *lip++ = lint1;
- lfp++;
- if (*lfp >= 0.0)
- lf = *lfp * *precision + 0.5;
- else
- lf = *lfp * *precision - 0.5;
- if (fabs(lf) > MAXABS) {
- /* scaling would cause overflow */
- errval = 0;
- }
- lint2 = lf;
- if (lint2 < minint[1]) minint[1] = lint2;
- if (lint2 > maxint[1]) maxint[1] = lint2;
- *lip++ = lint2;
- lfp++;
- if (*lfp >= 0.0)
- lf = *lfp * *precision + 0.5;
- else
- lf = *lfp * *precision - 0.5;
- if (fabs(lf) > MAXABS) {
- /* scaling would cause overflow */
- errval = 0;
- }
- lint3 = lf;
- if (lint3 < minint[2]) minint[2] = lint3;
- if (lint3 > maxint[2]) maxint[2] = lint3;
- *lip++ = lint3;
- lfp++;
- diff = abs(oldlint1-lint1)+abs(oldlint2-lint2)+abs(oldlint3-lint3);
- if (diff < mindiff && lfp > fp + 3)
- mindiff = diff;
- oldlint1 = lint1;
- oldlint2 = lint2;
- oldlint3 = lint3;
- }
- xdr_int(xdrs, &(minint[0]));
- xdr_int(xdrs, &(minint[1]));
- xdr_int(xdrs, &(minint[2]));
-
- xdr_int(xdrs, &(maxint[0]));
- xdr_int(xdrs, &(maxint[1]));
- xdr_int(xdrs, &(maxint[2]));
-
- if ((float)maxint[0] - (float)minint[0] >= MAXABS ||
- (float)maxint[1] - (float)minint[1] >= MAXABS ||
- (float)maxint[2] - (float)minint[2] >= MAXABS) {
- /* turning value in unsigned by subtracting minint
- * would cause overflow
- */
- errval = 0;
- }
- sizeint[0] = maxint[0] - minint[0]+1;
- sizeint[1] = maxint[1] - minint[1]+1;
- sizeint[2] = maxint[2] - minint[2]+1;
-
- /* check if one of the sizes is to big to be multiplied */
- if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) {
- bitsizeint[0] = sizeofint(sizeint[0]);
- bitsizeint[1] = sizeofint(sizeint[1]);
- bitsizeint[2] = sizeofint(sizeint[2]);
- bitsize = 0; /* flag the use of large sizes */
- } else {
- bitsize = sizeofints(3, sizeint);
- }
- lip = ip;
- luip = (unsigned int *) ip;
- smallidx = FIRSTIDX;
- while (smallidx < LASTIDX && magicints[smallidx] < mindiff) {
- smallidx++;
- }
- xdr_int(xdrs, &smallidx);
- maxidx = MIN(LASTIDX, smallidx + 8) ;
- minidx = maxidx - 8; /* often this equal smallidx */
- smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2;
- small = magicints[smallidx] / 2;
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx];
- larger = magicints[maxidx] / 2;
- i = 0;
- while (i < *size) {
- is_small = 0;
- thiscoord = (int *)(luip) + i * 3;
- if (smallidx < maxidx && i >= 1 &&
- abs(thiscoord[0] - prevcoord[0]) < larger &&
- abs(thiscoord[1] - prevcoord[1]) < larger &&
- abs(thiscoord[2] - prevcoord[2]) < larger) {
- is_smaller = 1;
- } else if (smallidx > minidx) {
- is_smaller = -1;
- } else {
- is_smaller = 0;
- }
- if (i + 1 < *size) {
- if (abs(thiscoord[0] - thiscoord[3]) < small &&
- abs(thiscoord[1] - thiscoord[4]) < small &&
- abs(thiscoord[2] - thiscoord[5]) < small) {
- /* interchange first with second atom for better
- * compression of water molecules
- */
- tmp = thiscoord[0]; thiscoord[0] = thiscoord[3];
- thiscoord[3] = tmp;
- tmp = thiscoord[1]; thiscoord[1] = thiscoord[4];
- thiscoord[4] = tmp;
- tmp = thiscoord[2]; thiscoord[2] = thiscoord[5];
- thiscoord[5] = tmp;
- is_small = 1;
- }
-
- }
- tmpcoord[0] = thiscoord[0] - minint[0];
- tmpcoord[1] = thiscoord[1] - minint[1];
- tmpcoord[2] = thiscoord[2] - minint[2];
- if (bitsize == 0) {
- sendbits(buf, bitsizeint[0], tmpcoord[0]);
- sendbits(buf, bitsizeint[1], tmpcoord[1]);
- sendbits(buf, bitsizeint[2], tmpcoord[2]);
- } else {
- sendints(buf, 3, bitsize, sizeint, tmpcoord);
- }
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
- thiscoord = thiscoord + 3;
- i++;
-
- run = 0;
- if (is_small == 0 && is_smaller == -1)
- is_smaller = 0;
- while (is_small && run < 8*3) {
- if (is_smaller == -1 && (
- SQR(thiscoord[0] - prevcoord[0]) +
- SQR(thiscoord[1] - prevcoord[1]) +
- SQR(thiscoord[2] - prevcoord[2]) >= smaller * smaller)) {
- is_smaller = 0;
- }
-
- tmpcoord[run++] = thiscoord[0] - prevcoord[0] + small;
- tmpcoord[run++] = thiscoord[1] - prevcoord[1] + small;
- tmpcoord[run++] = thiscoord[2] - prevcoord[2] + small;
-
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
-
- i++;
- thiscoord = thiscoord + 3;
- is_small = 0;
- if (i < *size &&
- abs(thiscoord[0] - prevcoord[0]) < small &&
- abs(thiscoord[1] - prevcoord[1]) < small &&
- abs(thiscoord[2] - prevcoord[2]) < small) {
- is_small = 1;
- }
- }
- if (run != prevrun || is_smaller != 0) {
- prevrun = run;
- sendbits(buf, 1, 1); /* flag the change in run-length */
- sendbits(buf, 5, run+is_smaller+1);
- } else {
- sendbits(buf, 1, 0); /* flag the fact that runlength did not change */
- }
- for (k=0; k < run; k+=3) {
- sendints(buf, 3, smallidx, sizesmall, &tmpcoord[k]);
- }
- if (is_smaller != 0) {
- smallidx += is_smaller;
- if (is_smaller < 0) {
- small = smaller;
- smaller = magicints[smallidx-1] / 2;
- } else {
- smaller = small;
- small = magicints[smallidx] / 2;
- }
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx];
- }
- }
- if (buf[1] != 0) buf[0]++;;
- xdr_int(xdrs, &(buf[0])); /* buf[0] holds the length in bytes */
- return errval * (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0]));
- } else {
-
- /* xdrs is open for reading */
-
- if (xdr_int(xdrs, &lsize) == 0)
- return 0;
- if (*size != 0 && lsize != *size) {
- fprintf(stderr, "wrong number of coordinates in xdr3dfcoor; "
- "%d arg vs %d in file", *size, lsize);
- }
- *size = lsize;
- size3 = *size * 3;
- if (*size <= 9) {
- return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp),
- (xdrproc_t)xdr_float));
- }
- xdr_float(xdrs, precision);
- if (ip == NULL) {
- ip = (int *)malloc(size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)malloc(bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- } else if (*size > oldsize) {
- ip = (int *)realloc(ip, size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)realloc(buf, bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- }
- buf[0] = buf[1] = buf[2] = 0;
-
- xdr_int(xdrs, &(minint[0]));
- xdr_int(xdrs, &(minint[1]));
- xdr_int(xdrs, &(minint[2]));
-
- xdr_int(xdrs, &(maxint[0]));
- xdr_int(xdrs, &(maxint[1]));
- xdr_int(xdrs, &(maxint[2]));
-
- sizeint[0] = maxint[0] - minint[0]+1;
- sizeint[1] = maxint[1] - minint[1]+1;
- sizeint[2] = maxint[2] - minint[2]+1;
-
- /* check if one of the sizes is to big to be multiplied */
- if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) {
- bitsizeint[0] = sizeofint(sizeint[0]);
- bitsizeint[1] = sizeofint(sizeint[1]);
- bitsizeint[2] = sizeofint(sizeint[2]);
- bitsize = 0; /* flag the use of large sizes */
- } else {
- bitsize = sizeofints(3, sizeint);
- }
-
- xdr_int(xdrs, &smallidx);
- maxidx = MIN(LASTIDX, smallidx + 8) ;
- minidx = maxidx - 8; /* often this equal smallidx */
- smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2;
- small = magicints[smallidx] / 2;
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ;
- larger = magicints[maxidx];
-
- /* buf[0] holds the length in bytes */
-
- if (xdr_int(xdrs, &(buf[0])) == 0)
- return 0;
- if (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0]) == 0)
- return 0;
- buf[0] = buf[1] = buf[2] = 0;
-
- lfp = fp;
- inv_precision = 1.0 / * precision;
- run = 0;
- i = 0;
- lip = ip;
- while ( i < lsize ) {
- thiscoord = (int *)(lip) + i * 3;
-
- if (bitsize == 0) {
- thiscoord[0] = receivebits(buf, bitsizeint[0]);
- thiscoord[1] = receivebits(buf, bitsizeint[1]);
- thiscoord[2] = receivebits(buf, bitsizeint[2]);
- } else {
- receiveints(buf, 3, bitsize, sizeint, thiscoord);
- }
-
- i++;
- thiscoord[0] += minint[0];
- thiscoord[1] += minint[1];
- thiscoord[2] += minint[2];
-
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
-
-
- flag = receivebits(buf, 1);
- is_smaller = 0;
- if (flag == 1) {
- run = receivebits(buf, 5);
- is_smaller = run % 3;
- run -= is_smaller;
- is_smaller--;
- }
- if (run > 0) {
- thiscoord += 3;
- for (k = 0; k < run; k+=3) {
- receiveints(buf, 3, smallidx, sizesmall, thiscoord);
- i++;
- thiscoord[0] += prevcoord[0] - small;
- thiscoord[1] += prevcoord[1] - small;
- thiscoord[2] += prevcoord[2] - small;
- if (k == 0) {
- /* interchange first with second atom for better
- * compression of water molecules
- */
- tmp = thiscoord[0]; thiscoord[0] = prevcoord[0];
- prevcoord[0] = tmp;
- tmp = thiscoord[1]; thiscoord[1] = prevcoord[1];
- prevcoord[1] = tmp;
- tmp = thiscoord[2]; thiscoord[2] = prevcoord[2];
- prevcoord[2] = tmp;
- *lfp++ = prevcoord[0] * inv_precision;
- *lfp++ = prevcoord[1] * inv_precision;
- *lfp++ = prevcoord[2] * inv_precision;
- } else {
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
- }
- *lfp++ = thiscoord[0] * inv_precision;
- *lfp++ = thiscoord[1] * inv_precision;
- *lfp++ = thiscoord[2] * inv_precision;
- }
- } else {
- *lfp++ = thiscoord[0] * inv_precision;
- *lfp++ = thiscoord[1] * inv_precision;
- *lfp++ = thiscoord[2] * inv_precision;
- }
- smallidx += is_smaller;
- if (is_smaller < 0) {
- small = smaller;
- if (smallidx > FIRSTIDX) {
- smaller = magicints[smallidx - 1] /2;
- } else {
- smaller = 0;
- }
- } else if (is_smaller > 0) {
- smaller = small;
- small = magicints[smallidx] / 2;
- }
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ;
- }
- }
- return 1;
-}
-
-
-
+++ /dev/null
-/*____________________________________________________________________________
- |
- | libxdrf - portable fortran interface to xdr. some xdr routines
- | are C routines for compressed coordinates
- |
- | version 1.1
- |
- | This collection of routines is intended to write and read
- | data in a portable way to a file, so data written on one type
- | of machine can be read back on a different type.
- |
- | all fortran routines use an integer 'xdrid', which is an id to the
- | current xdr file, and is set by xdrfopen.
- | most routines have in integer 'ret' which is the return value.
- | The value of 'ret' is zero on failure, and most of the time one
- | on succes.
- |
- | There are three routines useful for C users:
- | xdropen(), xdrclose(), xdr3dfcoord().
- | The first two replace xdrstdio_create and xdr_destroy, and *must* be
- | used when you plan to use xdr3dfcoord(). (they are also a bit
- | easier to interface). For writing data other than compressed coordinates
- | you should use the standard C xdr routines (see xdr man page)
- |
- | xdrfopen(xdrid, filename, mode, ret)
- | character *(*) filename
- | character *(*) mode
- |
- | this will open the file with the given filename (string)
- | and the given mode, it returns an id in xdrid, which is
- | to be used in all other calls to xdrf routines.
- | mode is 'w' to create, or update an file, for all other
- | values of mode the file is opened for reading
- |
- | you need to call xdrfclose to flush the output and close
- | the file.
- | Note that you should not use xdrstdio_create, which comes with the
- | standard xdr library
- |
- | xdrfclose(xdrid, ret)
- | flush the data to the file, and closes the file;
- | You should not use xdr_destroy (which comes standard with
- | the xdr libraries.
- |
- | xdrfbool(xdrid, bp, ret)
- | integer pb
- |
- | This filter produces values of either 1 or 0
- |
- | xdrfchar(xdrid, cp, ret)
- | character cp
- |
- | filter that translate between characters and their xdr representation
- | Note that the characters in not compressed and occupies 4 bytes.
- |
- | xdrfdouble(xdrid, dp, ret)
- | double dp
- |
- | read/write a double.
- |
- | xdrffloat(xdrid, fp, ret)
- | float fp
- |
- | read/write a float.
- |
- | xdrfint(xdrid, ip, ret)
- | integer ip
- |
- | read/write integer.
- |
- | xdrflong(xdrid, lp, ret)
- | integer lp
- |
- | this routine has a possible portablility problem due to 64 bits longs.
- |
- | xdrfshort(xdrid, sp, ret)
- | integer *2 sp
- |
- | xdrfstring(xdrid, sp, maxsize, ret)
- | character *(*)
- | integer maxsize
- |
- | read/write a string, with maximum length given by maxsize
- |
- | xdrfwrapstring(xdris, sp, ret)
- | character *(*)
- |
- | read/write a string (it is the same as xdrfstring accept that it finds
- | the stringlength itself.
- |
- | xdrfvector(xdrid, cp, size, xdrfproc, ret)
- | character *(*)
- | integer size
- | external xdrfproc
- |
- | read/write an array pointed to by cp, with number of elements
- | defined by 'size'. the routine 'xdrfproc' is the name
- | of one of the above routines to read/write data (like xdrfdouble)
- | In contrast with the c-version you don't need to specify the
- | byte size of an element.
- | xdrfstring is not allowed here (it is in the c version)
- |
- | xdrf3dfcoord(xdrid, fp, size, precision, ret)
- | real (*) fp
- | real precision
- | integer size
- |
- | this is *NOT* a standard xdr routine. I named it this way, because
- | it invites people to use the other xdr routines.
- | It is introduced to store specifically 3d coordinates of molecules
- | (as found in molecular dynamics) and it writes it in a compressed way.
- | It starts by multiplying all numbers by precision and
- | rounding the result to integer. effectively converting
- | all floating point numbers to fixed point.
- | it uses an algorithm for compression that is optimized for
- | molecular data, but could be used for other 3d coordinates
- | as well. There is subtantial overhead involved, so call this
- | routine only if you have a large number of coordinates to read/write
- |
- | ________________________________________________________________________
- |
- | Below are the routines to be used by C programmers. Use the 'normal'
- | xdr routines to write integers, floats, etc (see man xdr)
- |
- | int xdropen(XDR *xdrs, const char *filename, const char *type)
- | This will open the file with the given filename and the
- | given mode. You should pass it an allocated XDR struct
- | in xdrs, to be used in all other calls to xdr routines.
- | Mode is 'w' to create, or update an file, and for all
- | other values of mode the file is opened for reading.
- | You need to call xdrclose to flush the output and close
- | the file.
- |
- | Note that you should not use xdrstdio_create, which
- | comes with the standard xdr library.
- |
- | int xdrclose(XDR *xdrs)
- | Flush the data to the file, and close the file;
- | You should not use xdr_destroy (which comes standard
- | with the xdr libraries).
- |
- | int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision)
- | This is \fInot\fR a standard xdr routine. I named it this
- | way, because it invites people to use the other xdr
- | routines.
- |
- | (c) 1995 Frans van Hoesel, hoesel@chem.rug.nl
-*/
-
-
-#include <limits.h>
-#include <malloc.h>
-#include <math.h>
-/* #include <rpc/rpc.h>
-#include <rpc/xdr.h> */
-#include "xdr.h"
-#include <stdio.h>
-#include <stdlib.h>
-#include "xdrf.h"
-
-int ftocstr(char *, int, char *, int);
-int ctofstr(char *, int, char *);
-
-#define MAXID 20
-static FILE *xdrfiles[MAXID];
-static XDR *xdridptr[MAXID];
-static char xdrmodes[MAXID];
-static unsigned int cnt;
-
-typedef void (* FUNCTION(xdrfproc)) (int *, void *, int *);
-
-void
-FUNCTION(xdrfbool) ARGS(`xdrid, pb, ret')
-int *xdrid, *ret;
-int *pb;
-{
- *ret = xdr_bool(xdridptr[*xdrid], (bool_t *) pb);
- cnt += sizeof(int);
-}
-
-void
-FUNCTION(xdrfchar) ARGS(`xdrid, cp, ret')
-int *xdrid, *ret;
-char *cp;
-{
- *ret = xdr_char(xdridptr[*xdrid], cp);
- cnt += sizeof(char);
-}
-
-void
-FUNCTION(xdrfdouble) ARGS(`xdrid, dp, ret')
-int *xdrid, *ret;
-double *dp;
-{
- *ret = xdr_double(xdridptr[*xdrid], dp);
- cnt += sizeof(double);
-}
-
-void
-FUNCTION(xdrffloat) ARGS(`xdrid, fp, ret')
-int *xdrid, *ret;
-float *fp;
-{
- *ret = xdr_float(xdridptr[*xdrid], fp);
- cnt += sizeof(float);
-}
-
-void
-FUNCTION(xdrfint) ARGS(`xdrid, ip, ret')
-int *xdrid, *ret;
-int *ip;
-{
- *ret = xdr_int(xdridptr[*xdrid], ip);
- cnt += sizeof(int);
-}
-
-void
-FUNCTION(xdrflong) ARGS(`xdrid, lp, ret')
-int *xdrid, *ret;
-long *lp;
-{
- *ret = xdr_long(xdridptr[*xdrid], lp);
- cnt += sizeof(long);
-}
-
-void
-FUNCTION(xdrfshort) ARGS(`xdrid, sp, ret')
-int *xdrid, *ret;
-short *sp;
-{
- *ret = xdr_short(xdridptr[*xdrid], sp);
- cnt += sizeof(sp);
-}
-
-void
-FUNCTION(xdrfuchar) ARGS(`xdrid, ucp, ret')
-int *xdrid, *ret;
-char *ucp;
-{
- *ret = xdr_u_char(xdridptr[*xdrid], ucp);
- cnt += sizeof(char);
-}
-
-void
-FUNCTION(xdrfulong) ARGS(`xdrid, ulp, ret')
-int *xdrid, *ret;
-unsigned long *ulp;
-{
- *ret = xdr_u_long(xdridptr[*xdrid], ulp);
- cnt += sizeof(unsigned long);
-}
-
-void
-FUNCTION(xdrfushort) ARGS(`xdrid, usp, ret')
-int *xdrid, *ret;
-unsigned short *usp;
-{
- *ret = xdr_u_short(xdridptr[*xdrid], usp);
- cnt += sizeof(unsigned short);
-}
-
-void
-FUNCTION(xdrf3dfcoord) ARGS(`xdrid, fp, size, precision, ret')
-int *xdrid, *ret;
-float *fp;
-int *size;
-float *precision;
-{
- *ret = xdr3dfcoord(xdridptr[*xdrid], fp, size, precision);
-}
-
-void
-FUNCTION(xdrfstring) ARGS(`xdrid, STRING_ARG(sp), maxsize, ret')
-int *xdrid, *ret;
-STRING_ARG_DECL(sp);
-int *maxsize;
-{
- char *tsp;
-
- tsp = (char*) malloc(((STRING_LEN(sp)) + 1) * sizeof(char));
- if (tsp == NULL) {
- *ret = -1;
- return;
- }
- if (ftocstr(tsp, *maxsize+1, STRING_PTR(sp), STRING_LEN(sp))) {
- *ret = -1;
- free(tsp);
- return;
- }
- *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int) *maxsize);
- ctofstr( STRING_PTR(sp), STRING_LEN(sp), tsp);
- cnt += *maxsize;
- free(tsp);
-}
-
-void
-FUNCTION(xdrfwrapstring) ARGS(`xdrid, STRING_ARG(sp), ret')
-int *xdrid, *ret;
-STRING_ARG_DECL(sp);
-{
- char *tsp;
- int maxsize;
- maxsize = (STRING_LEN(sp)) + 1;
- tsp = (char*) malloc(maxsize * sizeof(char));
- if (tsp == NULL) {
- *ret = -1;
- return;
- }
- if (ftocstr(tsp, maxsize, STRING_PTR(sp), STRING_LEN(sp))) {
- *ret = -1;
- free(tsp);
- return;
- }
- *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int)maxsize);
- ctofstr( STRING_PTR(sp), STRING_LEN(sp), tsp);
- cnt += maxsize;
- free(tsp);
-}
-
-void
-FUNCTION(xdrfopaque) ARGS(`xdrid, cp, ccnt, ret')
-int *xdrid, *ret;
-caddr_t *cp;
-int *ccnt;
-{
- *ret = xdr_opaque(xdridptr[*xdrid], (caddr_t)*cp, (u_int)*ccnt);
- cnt += *ccnt;
-}
-
-void
-FUNCTION(xdrfsetpos) ARGS(`xdrid, pos, ret')
-int *xdrid, *ret;
-int *pos;
-{
- *ret = xdr_setpos(xdridptr[*xdrid], (u_int) *pos);
-}
-
-void
-FUNCTION(xdrf) ARGS(`xdrid, pos')
-int *xdrid, *pos;
-{
- *pos = xdr_getpos(xdridptr[*xdrid]);
-}
-
-void
-FUNCTION(xdrfvector) ARGS(`xdrid, cp, size, elproc, ret')
-int *xdrid, *ret;
-char *cp;
-int *size;
-FUNCTION(xdrfproc) elproc;
-{
- int lcnt;
- cnt = 0;
- for (lcnt = 0; lcnt < *size; lcnt++) {
- elproc(xdrid, (cp+cnt) , ret);
- }
-}
-
-
-void
-FUNCTION(xdrfclose) ARGS(`xdrid, ret')
-int *xdrid;
-int *ret;
-{
- *ret = xdrclose(xdridptr[*xdrid]);
- cnt = 0;
-}
-
-void
-FUNCTION(xdrfopen) ARGS(`xdrid, STRING_ARG(fp), STRING_ARG(mode), ret')
-int *xdrid;
-STRING_ARG_DECL(fp);
-STRING_ARG_DECL(mode);
-int *ret;
-{
- char fname[512];
- char fmode[3];
-
- if (ftocstr(fname, sizeof(fname), STRING_PTR(fp), STRING_LEN(fp))) {
- *ret = 0;
- }
- if (ftocstr(fmode, sizeof(fmode), STRING_PTR(mode),
- STRING_LEN(mode))) {
- *ret = 0;
- }
-
- *xdrid = xdropen(NULL, fname, fmode);
- if (*xdrid == 0)
- *ret = 0;
- else
- *ret = 1;
-}
-
-/*___________________________________________________________________________
- |
- | what follows are the C routines for opening, closing xdr streams
- | and the routine to read/write compressed coordinates together
- | with some routines to assist in this task (those are marked
- | static and cannot be called from user programs)
-*/
-#define MAXABS INT_MAX-2
-
-#ifndef MIN
-#define MIN(x,y) ((x) < (y) ? (x):(y))
-#endif
-#ifndef MAX
-#define MAX(x,y) ((x) > (y) ? (x):(y))
-#endif
-#ifndef SQR
-#define SQR(x) ((x)*(x))
-#endif
-static int magicints[] = {
- 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 8, 10, 12, 16, 20, 25, 32, 40, 50, 64,
- 80, 101, 128, 161, 203, 256, 322, 406, 512, 645,
- 812, 1024, 1290, 1625, 2048, 2580, 3250, 4096, 5060, 6501,
- 8192, 10321, 13003, 16384, 20642, 26007, 32768, 41285, 52015, 65536,
- 82570, 104031, 131072, 165140, 208063, 262144, 330280, 416127, 524287, 660561,
- 832255, 1048576, 1321122, 1664510, 2097152, 2642245, 3329021, 4194304, 5284491, 6658042,
- 8388607, 10568983, 13316085, 16777216 };
-
-#define FIRSTIDX 9
-/* note that magicints[FIRSTIDX-1] == 0 */
-#define LASTIDX (sizeof(magicints) / sizeof(*magicints))
-
-
-/*__________________________________________________________________________
- |
- | xdropen - open xdr file
- |
- | This versions differs from xdrstdio_create, because I need to know
- | the state of the file (read or write) so I can use xdr3dfcoord
- | in eigther read or write mode, and the file descriptor
- | so I can close the file (something xdr_destroy doesn't do).
- |
-*/
-
-int xdropen(XDR *xdrs, const char *filename, const char *type) {
- static int init_done = 0;
- enum xdr_op lmode;
- const char *type1;
- int xdrid;
-
- if (init_done == 0) {
- for (xdrid = 1; xdrid < MAXID; xdrid++) {
- xdridptr[xdrid] = NULL;
- }
- init_done = 1;
- }
- xdrid = 1;
- while (xdrid < MAXID && xdridptr[xdrid] != NULL) {
- xdrid++;
- }
- if (xdrid == MAXID) {
- return 0;
- }
- if (*type == 'w' || *type == 'W') {
- type = "w+";
- type1 = "a+";
- lmode = XDR_ENCODE;
- } else {
- type = "r";
- type1 = "r";
- lmode = XDR_DECODE;
- }
- xdrfiles[xdrid] = fopen(filename, type1);
- if (xdrfiles[xdrid] == NULL) {
- xdrs = NULL;
- return 0;
- }
- xdrmodes[xdrid] = *type;
- /* next test isn't usefull in the case of C language
- * but is used for the Fortran interface
- * (C users are expected to pass the address of an already allocated
- * XDR staructure)
- */
- if (xdrs == NULL) {
- xdridptr[xdrid] = (XDR *) malloc(sizeof(XDR));
- xdrstdio_create(xdridptr[xdrid], xdrfiles[xdrid], lmode);
- } else {
- xdridptr[xdrid] = xdrs;
- xdrstdio_create(xdrs, xdrfiles[xdrid], lmode);
- }
- return xdrid;
-}
-
-/*_________________________________________________________________________
- |
- | xdrclose - close a xdr file
- |
- | This will flush the xdr buffers, and destroy the xdr stream.
- | It also closes the associated file descriptor (this is *not*
- | done by xdr_destroy).
- |
-*/
-
-int xdrclose(XDR *xdrs) {
- int xdrid;
-
- if (xdrs == NULL) {
- fprintf(stderr, "xdrclose: passed a NULL pointer\n");
- exit(1);
- }
- for (xdrid = 1; xdrid < MAXID; xdrid++) {
- if (xdridptr[xdrid] == xdrs) {
-
- xdr_destroy(xdrs);
- fclose(xdrfiles[xdrid]);
- xdridptr[xdrid] = NULL;
- return 1;
- }
- }
- fprintf(stderr, "xdrclose: no such open xdr file\n");
- exit(1);
-
-}
-
-/*____________________________________________________________________________
- |
- | sendbits - encode num into buf using the specified number of bits
- |
- | This routines appends the value of num to the bits already present in
- | the array buf. You need to give it the number of bits to use and you
- | better make sure that this number of bits is enough to hold the value
- | Also num must be positive.
- |
-*/
-
-static void sendbits(int buf[], int num_of_bits, int num) {
-
- unsigned int cnt, lastbyte;
- int lastbits;
- unsigned char * cbuf;
-
- cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf);
- cnt = (unsigned int) buf[0];
- lastbits = buf[1];
- lastbyte =(unsigned int) buf[2];
- while (num_of_bits >= 8) {
- lastbyte = (lastbyte << 8) | ((num >> (num_of_bits -8)) /* & 0xff*/);
- cbuf[cnt++] = lastbyte >> lastbits;
- num_of_bits -= 8;
- }
- if (num_of_bits > 0) {
- lastbyte = (lastbyte << num_of_bits) | num;
- lastbits += num_of_bits;
- if (lastbits >= 8) {
- lastbits -= 8;
- cbuf[cnt++] = lastbyte >> lastbits;
- }
- }
- buf[0] = cnt;
- buf[1] = lastbits;
- buf[2] = lastbyte;
- if (lastbits>0) {
- cbuf[cnt] = lastbyte << (8 - lastbits);
- }
-}
-
-/*_________________________________________________________________________
- |
- | sizeofint - calculate bitsize of an integer
- |
- | return the number of bits needed to store an integer with given max size
- |
-*/
-
-static int sizeofint(const int size) {
- unsigned int num = 1;
- int num_of_bits = 0;
-
- while (size >= num && num_of_bits < 32) {
- num_of_bits++;
- num <<= 1;
- }
- return num_of_bits;
-}
-
-/*___________________________________________________________________________
- |
- | sizeofints - calculate 'bitsize' of compressed ints
- |
- | given the number of small unsigned integers and the maximum value
- | return the number of bits needed to read or write them with the
- | routines receiveints and sendints. You need this parameter when
- | calling these routines. Note that for many calls I can use
- | the variable 'smallidx' which is exactly the number of bits, and
- | So I don't need to call 'sizeofints for those calls.
-*/
-
-static int sizeofints( const int num_of_ints, unsigned int sizes[]) {
- int i, num;
- unsigned int num_of_bytes, num_of_bits, bytes[32], bytecnt, tmp;
- num_of_bytes = 1;
- bytes[0] = 1;
- num_of_bits = 0;
- for (i=0; i < num_of_ints; i++) {
- tmp = 0;
- for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) {
- tmp = bytes[bytecnt] * sizes[i] + tmp;
- bytes[bytecnt] = tmp & 0xff;
- tmp >>= 8;
- }
- while (tmp != 0) {
- bytes[bytecnt++] = tmp & 0xff;
- tmp >>= 8;
- }
- num_of_bytes = bytecnt;
- }
- num = 1;
- num_of_bytes--;
- while (bytes[num_of_bytes] >= num) {
- num_of_bits++;
- num *= 2;
- }
- return num_of_bits + num_of_bytes * 8;
-
-}
-
-/*____________________________________________________________________________
- |
- | sendints - send a small set of small integers in compressed format
- |
- | this routine is used internally by xdr3dfcoord, to send a set of
- | small integers to the buffer.
- | Multiplication with fixed (specified maximum ) sizes is used to get
- | to one big, multibyte integer. Allthough the routine could be
- | modified to handle sizes bigger than 16777216, or more than just
- | a few integers, this is not done, because the gain in compression
- | isn't worth the effort. Note that overflowing the multiplication
- | or the byte buffer (32 bytes) is unchecked and causes bad results.
- |
- */
-
-static void sendints(int buf[], const int num_of_ints, const int num_of_bits,
- unsigned int sizes[], unsigned int nums[]) {
-
- int i;
- unsigned int bytes[32], num_of_bytes, bytecnt, tmp;
-
- tmp = nums[0];
- num_of_bytes = 0;
- do {
- bytes[num_of_bytes++] = tmp & 0xff;
- tmp >>= 8;
- } while (tmp != 0);
-
- for (i = 1; i < num_of_ints; i++) {
- if (nums[i] >= sizes[i]) {
- fprintf(stderr,"major breakdown in sendints num %d doesn't "
- "match size %d\n", nums[i], sizes[i]);
- exit(1);
- }
- /* use one step multiply */
- tmp = nums[i];
- for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) {
- tmp = bytes[bytecnt] * sizes[i] + tmp;
- bytes[bytecnt] = tmp & 0xff;
- tmp >>= 8;
- }
- while (tmp != 0) {
- bytes[bytecnt++] = tmp & 0xff;
- tmp >>= 8;
- }
- num_of_bytes = bytecnt;
- }
- if (num_of_bits >= num_of_bytes * 8) {
- for (i = 0; i < num_of_bytes; i++) {
- sendbits(buf, 8, bytes[i]);
- }
- sendbits(buf, num_of_bits - num_of_bytes * 8, 0);
- } else {
- for (i = 0; i < num_of_bytes-1; i++) {
- sendbits(buf, 8, bytes[i]);
- }
- sendbits(buf, num_of_bits- (num_of_bytes -1) * 8, bytes[i]);
- }
-}
-
-
-/*___________________________________________________________________________
- |
- | receivebits - decode number from buf using specified number of bits
- |
- | extract the number of bits from the array buf and construct an integer
- | from it. Return that value.
- |
-*/
-
-static int receivebits(int buf[], int num_of_bits) {
-
- int cnt, num;
- unsigned int lastbits, lastbyte;
- unsigned char * cbuf;
- int mask = (1 << num_of_bits) -1;
-
- cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf);
- cnt = buf[0];
- lastbits = (unsigned int) buf[1];
- lastbyte = (unsigned int) buf[2];
-
- num = 0;
- while (num_of_bits >= 8) {
- lastbyte = ( lastbyte << 8 ) | cbuf[cnt++];
- num |= (lastbyte >> lastbits) << (num_of_bits - 8);
- num_of_bits -=8;
- }
- if (num_of_bits > 0) {
- if (lastbits < num_of_bits) {
- lastbits += 8;
- lastbyte = (lastbyte << 8) | cbuf[cnt++];
- }
- lastbits -= num_of_bits;
- num |= (lastbyte >> lastbits) & ((1 << num_of_bits) -1);
- }
- num &= mask;
- buf[0] = cnt;
- buf[1] = lastbits;
- buf[2] = lastbyte;
- return num;
-}
-
-/*____________________________________________________________________________
- |
- | receiveints - decode 'small' integers from the buf array
- |
- | this routine is the inverse from sendints() and decodes the small integers
- | written to buf by calculating the remainder and doing divisions with
- | the given sizes[]. You need to specify the total number of bits to be
- | used from buf in num_of_bits.
- |
-*/
-
-static void receiveints(int buf[], const int num_of_ints, int num_of_bits,
- unsigned int sizes[], int nums[]) {
- int bytes[32];
- int i, j, num_of_bytes, p, num;
-
- bytes[1] = bytes[2] = bytes[3] = 0;
- num_of_bytes = 0;
- while (num_of_bits > 8) {
- bytes[num_of_bytes++] = receivebits(buf, 8);
- num_of_bits -= 8;
- }
- if (num_of_bits > 0) {
- bytes[num_of_bytes++] = receivebits(buf, num_of_bits);
- }
- for (i = num_of_ints-1; i > 0; i--) {
- num = 0;
- for (j = num_of_bytes-1; j >=0; j--) {
- num = (num << 8) | bytes[j];
- p = num / sizes[i];
- bytes[j] = p;
- num = num - p * sizes[i];
- }
- nums[i] = num;
- }
- nums[0] = bytes[0] | (bytes[1] << 8) | (bytes[2] << 16) | (bytes[3] << 24);
-}
-
-/*____________________________________________________________________________
- |
- | xdr3dfcoord - read or write compressed 3d coordinates to xdr file.
- |
- | this routine reads or writes (depending on how you opened the file with
- | xdropen() ) a large number of 3d coordinates (stored in *fp).
- | The number of coordinates triplets to write is given by *size. On
- | read this number may be zero, in which case it reads as many as were written
- | or it may specify the number if triplets to read (which should match the
- | number written).
- | Compression is achieved by first converting all floating numbers to integer
- | using multiplication by *precision and rounding to the nearest integer.
- | Then the minimum and maximum value are calculated to determine the range.
- | The limited range of integers so found, is used to compress the coordinates.
- | In addition the differences between succesive coordinates is calculated.
- | If the difference happens to be 'small' then only the difference is saved,
- | compressing the data even more. The notion of 'small' is changed dynamically
- | and is enlarged or reduced whenever needed or possible.
- | Extra compression is achieved in the case of GROMOS and coordinates of
- | water molecules. GROMOS first writes out the Oxygen position, followed by
- | the two hydrogens. In order to make the differences smaller (and thereby
- | compression the data better) the order is changed into first one hydrogen
- | then the oxygen, followed by the other hydrogen. This is rather special, but
- | it shouldn't harm in the general case.
- |
- */
-
-int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) {
-
-
- static int *ip = NULL;
- static int oldsize;
- static int *buf;
-
- int minint[3], maxint[3], mindiff, *lip, diff;
- int lint1, lint2, lint3, oldlint1, oldlint2, oldlint3, smallidx;
- int minidx, maxidx;
- unsigned sizeint[3], sizesmall[3], bitsizeint[3], size3, *luip;
- int flag, k;
- int small, smaller, larger, i, is_small, is_smaller, run, prevrun;
- float *lfp, lf;
- int tmp, *thiscoord, prevcoord[3];
- unsigned int tmpcoord[30];
-
- int bufsize, xdrid, lsize;
- unsigned int bitsize;
- float inv_precision;
- int errval = 1;
-
- /* find out if xdrs is opened for reading or for writing */
- xdrid = 0;
- while (xdridptr[xdrid] != xdrs) {
- xdrid++;
- if (xdrid >= MAXID) {
- fprintf(stderr, "xdr error. no open xdr stream\n");
- exit (1);
- }
- }
- if (xdrmodes[xdrid] == 'w') {
-
- /* xdrs is open for writing */
-
- if (xdr_int(xdrs, size) == 0)
- return 0;
- size3 = *size * 3;
- /* when the number of coordinates is small, don't try to compress; just
- * write them as floats using xdr_vector
- */
- if (*size <= 9 ) {
- return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp),
- (xdrproc_t)xdr_float));
- }
-
- xdr_float(xdrs, precision);
- if (ip == NULL) {
- ip = (int *)malloc(size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)malloc(bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- } else if (*size > oldsize) {
- ip = (int *)realloc(ip, size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)realloc(buf, bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- }
- /* buf[0-2] are special and do not contain actual data */
- buf[0] = buf[1] = buf[2] = 0;
- minint[0] = minint[1] = minint[2] = INT_MAX;
- maxint[0] = maxint[1] = maxint[2] = INT_MIN;
- prevrun = -1;
- lfp = fp;
- lip = ip;
- mindiff = INT_MAX;
- oldlint1 = oldlint2 = oldlint3 = 0;
- while(lfp < fp + size3 ) {
- /* find nearest integer */
- if (*lfp >= 0.0)
- lf = *lfp * *precision + 0.5;
- else
- lf = *lfp * *precision - 0.5;
- if (fabs(lf) > MAXABS) {
- /* scaling would cause overflow */
- errval = 0;
- }
- lint1 = lf;
- if (lint1 < minint[0]) minint[0] = lint1;
- if (lint1 > maxint[0]) maxint[0] = lint1;
- *lip++ = lint1;
- lfp++;
- if (*lfp >= 0.0)
- lf = *lfp * *precision + 0.5;
- else
- lf = *lfp * *precision - 0.5;
- if (fabs(lf) > MAXABS) {
- /* scaling would cause overflow */
- errval = 0;
- }
- lint2 = lf;
- if (lint2 < minint[1]) minint[1] = lint2;
- if (lint2 > maxint[1]) maxint[1] = lint2;
- *lip++ = lint2;
- lfp++;
- if (*lfp >= 0.0)
- lf = *lfp * *precision + 0.5;
- else
- lf = *lfp * *precision - 0.5;
- if (fabs(lf) > MAXABS) {
- /* scaling would cause overflow */
- errval = 0;
- }
- lint3 = lf;
- if (lint3 < minint[2]) minint[2] = lint3;
- if (lint3 > maxint[2]) maxint[2] = lint3;
- *lip++ = lint3;
- lfp++;
- diff = abs(oldlint1-lint1)+abs(oldlint2-lint2)+abs(oldlint3-lint3);
- if (diff < mindiff && lfp > fp + 3)
- mindiff = diff;
- oldlint1 = lint1;
- oldlint2 = lint2;
- oldlint3 = lint3;
- }
- xdr_int(xdrs, &(minint[0]));
- xdr_int(xdrs, &(minint[1]));
- xdr_int(xdrs, &(minint[2]));
-
- xdr_int(xdrs, &(maxint[0]));
- xdr_int(xdrs, &(maxint[1]));
- xdr_int(xdrs, &(maxint[2]));
-
- if ((float)maxint[0] - (float)minint[0] >= MAXABS ||
- (float)maxint[1] - (float)minint[1] >= MAXABS ||
- (float)maxint[2] - (float)minint[2] >= MAXABS) {
- /* turning value in unsigned by subtracting minint
- * would cause overflow
- */
- errval = 0;
- }
- sizeint[0] = maxint[0] - minint[0]+1;
- sizeint[1] = maxint[1] - minint[1]+1;
- sizeint[2] = maxint[2] - minint[2]+1;
-
- /* check if one of the sizes is to big to be multiplied */
- if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) {
- bitsizeint[0] = sizeofint(sizeint[0]);
- bitsizeint[1] = sizeofint(sizeint[1]);
- bitsizeint[2] = sizeofint(sizeint[2]);
- bitsize = 0; /* flag the use of large sizes */
- } else {
- bitsize = sizeofints(3, sizeint);
- }
- lip = ip;
- luip = (unsigned int *) ip;
- smallidx = FIRSTIDX;
- while (smallidx < LASTIDX && magicints[smallidx] < mindiff) {
- smallidx++;
- }
- xdr_int(xdrs, &smallidx);
- maxidx = MIN(LASTIDX, smallidx + 8) ;
- minidx = maxidx - 8; /* often this equal smallidx */
- smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2;
- small = magicints[smallidx] / 2;
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx];
- larger = magicints[maxidx] / 2;
- i = 0;
- while (i < *size) {
- is_small = 0;
- thiscoord = (int *)(luip) + i * 3;
- if (smallidx < maxidx && i >= 1 &&
- abs(thiscoord[0] - prevcoord[0]) < larger &&
- abs(thiscoord[1] - prevcoord[1]) < larger &&
- abs(thiscoord[2] - prevcoord[2]) < larger) {
- is_smaller = 1;
- } else if (smallidx > minidx) {
- is_smaller = -1;
- } else {
- is_smaller = 0;
- }
- if (i + 1 < *size) {
- if (abs(thiscoord[0] - thiscoord[3]) < small &&
- abs(thiscoord[1] - thiscoord[4]) < small &&
- abs(thiscoord[2] - thiscoord[5]) < small) {
- /* interchange first with second atom for better
- * compression of water molecules
- */
- tmp = thiscoord[0]; thiscoord[0] = thiscoord[3];
- thiscoord[3] = tmp;
- tmp = thiscoord[1]; thiscoord[1] = thiscoord[4];
- thiscoord[4] = tmp;
- tmp = thiscoord[2]; thiscoord[2] = thiscoord[5];
- thiscoord[5] = tmp;
- is_small = 1;
- }
-
- }
- tmpcoord[0] = thiscoord[0] - minint[0];
- tmpcoord[1] = thiscoord[1] - minint[1];
- tmpcoord[2] = thiscoord[2] - minint[2];
- if (bitsize == 0) {
- sendbits(buf, bitsizeint[0], tmpcoord[0]);
- sendbits(buf, bitsizeint[1], tmpcoord[1]);
- sendbits(buf, bitsizeint[2], tmpcoord[2]);
- } else {
- sendints(buf, 3, bitsize, sizeint, tmpcoord);
- }
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
- thiscoord = thiscoord + 3;
- i++;
-
- run = 0;
- if (is_small == 0 && is_smaller == -1)
- is_smaller = 0;
- while (is_small && run < 8*3) {
- if (is_smaller == -1 && (
- SQR(thiscoord[0] - prevcoord[0]) +
- SQR(thiscoord[1] - prevcoord[1]) +
- SQR(thiscoord[2] - prevcoord[2]) >= smaller * smaller)) {
- is_smaller = 0;
- }
-
- tmpcoord[run++] = thiscoord[0] - prevcoord[0] + small;
- tmpcoord[run++] = thiscoord[1] - prevcoord[1] + small;
- tmpcoord[run++] = thiscoord[2] - prevcoord[2] + small;
-
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
-
- i++;
- thiscoord = thiscoord + 3;
- is_small = 0;
- if (i < *size &&
- abs(thiscoord[0] - prevcoord[0]) < small &&
- abs(thiscoord[1] - prevcoord[1]) < small &&
- abs(thiscoord[2] - prevcoord[2]) < small) {
- is_small = 1;
- }
- }
- if (run != prevrun || is_smaller != 0) {
- prevrun = run;
- sendbits(buf, 1, 1); /* flag the change in run-length */
- sendbits(buf, 5, run+is_smaller+1);
- } else {
- sendbits(buf, 1, 0); /* flag the fact that runlength did not change */
- }
- for (k=0; k < run; k+=3) {
- sendints(buf, 3, smallidx, sizesmall, &tmpcoord[k]);
- }
- if (is_smaller != 0) {
- smallidx += is_smaller;
- if (is_smaller < 0) {
- small = smaller;
- smaller = magicints[smallidx-1] / 2;
- } else {
- smaller = small;
- small = magicints[smallidx] / 2;
- }
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx];
- }
- }
- if (buf[1] != 0) buf[0]++;;
- xdr_int(xdrs, &(buf[0])); /* buf[0] holds the length in bytes */
- return errval * (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0]));
- } else {
-
- /* xdrs is open for reading */
-
- if (xdr_int(xdrs, &lsize) == 0)
- return 0;
- if (*size != 0 && lsize != *size) {
- fprintf(stderr, "wrong number of coordinates in xdr3dfcoor; "
- "%d arg vs %d in file", *size, lsize);
- }
- *size = lsize;
- size3 = *size * 3;
- if (*size <= 9) {
- return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp),
- (xdrproc_t)xdr_float));
- }
- xdr_float(xdrs, precision);
- if (ip == NULL) {
- ip = (int *)malloc(size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)malloc(bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- } else if (*size > oldsize) {
- ip = (int *)realloc(ip, size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)realloc(buf, bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- }
- buf[0] = buf[1] = buf[2] = 0;
-
- xdr_int(xdrs, &(minint[0]));
- xdr_int(xdrs, &(minint[1]));
- xdr_int(xdrs, &(minint[2]));
-
- xdr_int(xdrs, &(maxint[0]));
- xdr_int(xdrs, &(maxint[1]));
- xdr_int(xdrs, &(maxint[2]));
-
- sizeint[0] = maxint[0] - minint[0]+1;
- sizeint[1] = maxint[1] - minint[1]+1;
- sizeint[2] = maxint[2] - minint[2]+1;
-
- /* check if one of the sizes is to big to be multiplied */
- if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) {
- bitsizeint[0] = sizeofint(sizeint[0]);
- bitsizeint[1] = sizeofint(sizeint[1]);
- bitsizeint[2] = sizeofint(sizeint[2]);
- bitsize = 0; /* flag the use of large sizes */
- } else {
- bitsize = sizeofints(3, sizeint);
- }
-
- xdr_int(xdrs, &smallidx);
- maxidx = MIN(LASTIDX, smallidx + 8) ;
- minidx = maxidx - 8; /* often this equal smallidx */
- smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2;
- small = magicints[smallidx] / 2;
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ;
- larger = magicints[maxidx];
-
- /* buf[0] holds the length in bytes */
-
- if (xdr_int(xdrs, &(buf[0])) == 0)
- return 0;
- if (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0]) == 0)
- return 0;
- buf[0] = buf[1] = buf[2] = 0;
-
- lfp = fp;
- inv_precision = 1.0 / * precision;
- run = 0;
- i = 0;
- lip = ip;
- while ( i < lsize ) {
- thiscoord = (int *)(lip) + i * 3;
-
- if (bitsize == 0) {
- thiscoord[0] = receivebits(buf, bitsizeint[0]);
- thiscoord[1] = receivebits(buf, bitsizeint[1]);
- thiscoord[2] = receivebits(buf, bitsizeint[2]);
- } else {
- receiveints(buf, 3, bitsize, sizeint, thiscoord);
- }
-
- i++;
- thiscoord[0] += minint[0];
- thiscoord[1] += minint[1];
- thiscoord[2] += minint[2];
-
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
-
-
- flag = receivebits(buf, 1);
- is_smaller = 0;
- if (flag == 1) {
- run = receivebits(buf, 5);
- is_smaller = run % 3;
- run -= is_smaller;
- is_smaller--;
- }
- if (run > 0) {
- thiscoord += 3;
- for (k = 0; k < run; k+=3) {
- receiveints(buf, 3, smallidx, sizesmall, thiscoord);
- i++;
- thiscoord[0] += prevcoord[0] - small;
- thiscoord[1] += prevcoord[1] - small;
- thiscoord[2] += prevcoord[2] - small;
- if (k == 0) {
- /* interchange first with second atom for better
- * compression of water molecules
- */
- tmp = thiscoord[0]; thiscoord[0] = prevcoord[0];
- prevcoord[0] = tmp;
- tmp = thiscoord[1]; thiscoord[1] = prevcoord[1];
- prevcoord[1] = tmp;
- tmp = thiscoord[2]; thiscoord[2] = prevcoord[2];
- prevcoord[2] = tmp;
- *lfp++ = prevcoord[0] * inv_precision;
- *lfp++ = prevcoord[1] * inv_precision;
- *lfp++ = prevcoord[2] * inv_precision;
- } else {
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
- }
- *lfp++ = thiscoord[0] * inv_precision;
- *lfp++ = thiscoord[1] * inv_precision;
- *lfp++ = thiscoord[2] * inv_precision;
- }
- } else {
- *lfp++ = thiscoord[0] * inv_precision;
- *lfp++ = thiscoord[1] * inv_precision;
- *lfp++ = thiscoord[2] * inv_precision;
- }
- smallidx += is_smaller;
- if (is_smaller < 0) {
- small = smaller;
- if (smallidx > FIRSTIDX) {
- smaller = magicints[smallidx - 1] /2;
- } else {
- smaller = 0;
- }
- } else if (is_smaller > 0) {
- smaller = small;
- small = magicints[smallidx] / 2;
- }
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ;
- }
- }
- return 1;
-}
-
-
-
+++ /dev/null
-/*____________________________________________________________________________
- |
- | libxdrf - portable fortran interface to xdr. some xdr routines
- | are C routines for compressed coordinates
- |
- | version 1.1
- |
- | This collection of routines is intended to write and read
- | data in a portable way to a file, so data written on one type
- | of machine can be read back on a different type.
- |
- | all fortran routines use an integer 'xdrid', which is an id to the
- | current xdr file, and is set by xdrfopen.
- | most routines have in integer 'ret' which is the return value.
- | The value of 'ret' is zero on failure, and most of the time one
- | on succes.
- |
- | There are three routines useful for C users:
- | xdropen(), xdrclose(), xdr3dfcoord().
- | The first two replace xdrstdio_create and xdr_destroy, and *must* be
- | used when you plan to use xdr3dfcoord(). (they are also a bit
- | easier to interface). For writing data other than compressed coordinates
- | you should use the standard C xdr routines (see xdr man page)
- |
- | xdrfopen(xdrid, filename, mode, ret)
- | character *(*) filename
- | character *(*) mode
- |
- | this will open the file with the given filename (string)
- | and the given mode, it returns an id in xdrid, which is
- | to be used in all other calls to xdrf routines.
- | mode is 'w' to create, or update an file, for all other
- | values of mode the file is opened for reading
- |
- | you need to call xdrfclose to flush the output and close
- | the file.
- | Note that you should not use xdrstdio_create, which comes with the
- | standard xdr library
- |
- | xdrfclose(xdrid, ret)
- | flush the data to the file, and closes the file;
- | You should not use xdr_destroy (which comes standard with
- | the xdr libraries.
- |
- | xdrfbool(xdrid, bp, ret)
- | integer pb
- |
- | This filter produces values of either 1 or 0
- |
- | xdrfchar(xdrid, cp, ret)
- | character cp
- |
- | filter that translate between characters and their xdr representation
- | Note that the characters in not compressed and occupies 4 bytes.
- |
- | xdrfdouble(xdrid, dp, ret)
- | double dp
- |
- | read/write a double.
- |
- | xdrffloat(xdrid, fp, ret)
- | float fp
- |
- | read/write a float.
- |
- | xdrfint(xdrid, ip, ret)
- | integer ip
- |
- | read/write integer.
- |
- | xdrflong(xdrid, lp, ret)
- | integer lp
- |
- | this routine has a possible portablility problem due to 64 bits longs.
- |
- | xdrfshort(xdrid, sp, ret)
- | integer *2 sp
- |
- | xdrfstring(xdrid, sp, maxsize, ret)
- | character *(*)
- | integer maxsize
- |
- | read/write a string, with maximum length given by maxsize
- |
- | xdrfwrapstring(xdris, sp, ret)
- | character *(*)
- |
- | read/write a string (it is the same as xdrfstring accept that it finds
- | the stringlength itself.
- |
- | xdrfvector(xdrid, cp, size, xdrfproc, ret)
- | character *(*)
- | integer size
- | external xdrfproc
- |
- | read/write an array pointed to by cp, with number of elements
- | defined by 'size'. the routine 'xdrfproc' is the name
- | of one of the above routines to read/write data (like xdrfdouble)
- | In contrast with the c-version you don't need to specify the
- | byte size of an element.
- | xdrfstring is not allowed here (it is in the c version)
- |
- | xdrf3dfcoord(xdrid, fp, size, precision, ret)
- | real (*) fp
- | real precision
- | integer size
- |
- | this is *NOT* a standard xdr routine. I named it this way, because
- | it invites people to use the other xdr routines.
- | It is introduced to store specifically 3d coordinates of molecules
- | (as found in molecular dynamics) and it writes it in a compressed way.
- | It starts by multiplying all numbers by precision and
- | rounding the result to integer. effectively converting
- | all floating point numbers to fixed point.
- | it uses an algorithm for compression that is optimized for
- | molecular data, but could be used for other 3d coordinates
- | as well. There is subtantial overhead involved, so call this
- | routine only if you have a large number of coordinates to read/write
- |
- | ________________________________________________________________________
- |
- | Below are the routines to be used by C programmers. Use the 'normal'
- | xdr routines to write integers, floats, etc (see man xdr)
- |
- | int xdropen(XDR *xdrs, const char *filename, const char *type)
- | This will open the file with the given filename and the
- | given mode. You should pass it an allocated XDR struct
- | in xdrs, to be used in all other calls to xdr routines.
- | Mode is 'w' to create, or update an file, and for all
- | other values of mode the file is opened for reading.
- | You need to call xdrclose to flush the output and close
- | the file.
- |
- | Note that you should not use xdrstdio_create, which
- | comes with the standard xdr library.
- |
- | int xdrclose(XDR *xdrs)
- | Flush the data to the file, and close the file;
- | You should not use xdr_destroy (which comes standard
- | with the xdr libraries).
- |
- | int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision)
- | This is \fInot\fR a standard xdr routine. I named it this
- | way, because it invites people to use the other xdr
- | routines.
- |
- | (c) 1995 Frans van Hoesel, hoesel@chem.rug.nl
-*/
-
-
-#include <limits.h>
-#include <malloc.h>
-#include <math.h>
-#include <rpc/rpc.h>
-#include <rpc/xdr.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include "xdrf.h"
-
-int ftocstr(char *, int, char *, int);
-int ctofstr(char *, int, char *);
-
-#define MAXID 20
-static FILE *xdrfiles[MAXID];
-static XDR *xdridptr[MAXID];
-static char xdrmodes[MAXID];
-static unsigned int cnt;
-
-typedef void (* FUNCTION(xdrfproc)) (int *, void *, int *);
-
-void
-FUNCTION(xdrfbool) ARGS(`xdrid, pb, ret')
-int *xdrid, *ret;
-int *pb;
-{
- *ret = xdr_bool(xdridptr[*xdrid], (bool_t *) pb);
- cnt += sizeof(int);
-}
-
-void
-FUNCTION(xdrfchar) ARGS(`xdrid, cp, ret')
-int *xdrid, *ret;
-char *cp;
-{
- *ret = xdr_char(xdridptr[*xdrid], cp);
- cnt += sizeof(char);
-}
-
-void
-FUNCTION(xdrfdouble) ARGS(`xdrid, dp, ret')
-int *xdrid, *ret;
-double *dp;
-{
- *ret = xdr_double(xdridptr[*xdrid], dp);
- cnt += sizeof(double);
-}
-
-void
-FUNCTION(xdrffloat) ARGS(`xdrid, fp, ret')
-int *xdrid, *ret;
-float *fp;
-{
- *ret = xdr_float(xdridptr[*xdrid], fp);
- cnt += sizeof(float);
-}
-
-void
-FUNCTION(xdrfint) ARGS(`xdrid, ip, ret')
-int *xdrid, *ret;
-int *ip;
-{
- *ret = xdr_int(xdridptr[*xdrid], ip);
- cnt += sizeof(int);
-}
-
-void
-FUNCTION(xdrflong) ARGS(`xdrid, lp, ret')
-int *xdrid, *ret;
-long *lp;
-{
- *ret = xdr_long(xdridptr[*xdrid], lp);
- cnt += sizeof(long);
-}
-
-void
-FUNCTION(xdrfshort) ARGS(`xdrid, sp, ret')
-int *xdrid, *ret;
-short *sp;
-{
- *ret = xdr_short(xdridptr[*xdrid], sp);
- cnt += sizeof(sp);
-}
-
-void
-FUNCTION(xdrfuchar) ARGS(`xdrid, ucp, ret')
-int *xdrid, *ret;
-char *ucp;
-{
- *ret = xdr_u_char(xdridptr[*xdrid], ucp);
- cnt += sizeof(char);
-}
-
-void
-FUNCTION(xdrfulong) ARGS(`xdrid, ulp, ret')
-int *xdrid, *ret;
-unsigned long *ulp;
-{
- *ret = xdr_u_long(xdridptr[*xdrid], ulp);
- cnt += sizeof(unsigned long);
-}
-
-void
-FUNCTION(xdrfushort) ARGS(`xdrid, usp, ret')
-int *xdrid, *ret;
-unsigned short *usp;
-{
- *ret = xdr_u_short(xdridptr[*xdrid], usp);
- cnt += sizeof(unsigned short);
-}
-
-void
-FUNCTION(xdrf3dfcoord) ARGS(`xdrid, fp, size, precision, ret')
-int *xdrid, *ret;
-float *fp;
-int *size;
-float *precision;
-{
- *ret = xdr3dfcoord(xdridptr[*xdrid], fp, size, precision);
-}
-
-void
-FUNCTION(xdrfstring) ARGS(`xdrid, STRING_ARG(sp), maxsize, ret')
-int *xdrid, *ret;
-STRING_ARG_DECL(sp);
-int *maxsize;
-{
- char *tsp;
-
- tsp = (char*) malloc(((STRING_LEN(sp)) + 1) * sizeof(char));
- if (tsp == NULL) {
- *ret = -1;
- return;
- }
- if (ftocstr(tsp, *maxsize+1, STRING_PTR(sp), STRING_LEN(sp))) {
- *ret = -1;
- free(tsp);
- return;
- }
- *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int) *maxsize);
- ctofstr( STRING_PTR(sp), STRING_LEN(sp), tsp);
- cnt += *maxsize;
- free(tsp);
-}
-
-void
-FUNCTION(xdrfwrapstring) ARGS(`xdrid, STRING_ARG(sp), ret')
-int *xdrid, *ret;
-STRING_ARG_DECL(sp);
-{
- char *tsp;
- int maxsize;
- maxsize = (STRING_LEN(sp)) + 1;
- tsp = (char*) malloc(maxsize * sizeof(char));
- if (tsp == NULL) {
- *ret = -1;
- return;
- }
- if (ftocstr(tsp, maxsize, STRING_PTR(sp), STRING_LEN(sp))) {
- *ret = -1;
- free(tsp);
- return;
- }
- *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int)maxsize);
- ctofstr( STRING_PTR(sp), STRING_LEN(sp), tsp);
- cnt += maxsize;
- free(tsp);
-}
-
-void
-FUNCTION(xdrfopaque) ARGS(`xdrid, cp, ccnt, ret')
-int *xdrid, *ret;
-caddr_t *cp;
-int *ccnt;
-{
- *ret = xdr_opaque(xdridptr[*xdrid], (caddr_t)*cp, (u_int)*ccnt);
- cnt += *ccnt;
-}
-
-void
-FUNCTION(xdrfsetpos) ARGS(`xdrid, pos, ret')
-int *xdrid, *ret;
-int *pos;
-{
- *ret = xdr_setpos(xdridptr[*xdrid], (u_int) *pos);
-}
-
-void
-FUNCTION(xdrf) ARGS(`xdrid, pos')
-int *xdrid, *pos;
-{
- *pos = xdr_getpos(xdridptr[*xdrid]);
-}
-
-void
-FUNCTION(xdrfvector) ARGS(`xdrid, cp, size, elproc, ret')
-int *xdrid, *ret;
-char *cp;
-int *size;
-FUNCTION(xdrfproc) elproc;
-{
- int lcnt;
- cnt = 0;
- for (lcnt = 0; lcnt < *size; lcnt++) {
- elproc(xdrid, (cp+cnt) , ret);
- }
-}
-
-
-void
-FUNCTION(xdrfclose) ARGS(`xdrid, ret')
-int *xdrid;
-int *ret;
-{
- *ret = xdrclose(xdridptr[*xdrid]);
- cnt = 0;
-}
-
-void
-FUNCTION(xdrfopen) ARGS(`xdrid, STRING_ARG(fp), STRING_ARG(mode), ret')
-int *xdrid;
-STRING_ARG_DECL(fp);
-STRING_ARG_DECL(mode);
-int *ret;
-{
- char fname[512];
- char fmode[3];
-
- if (ftocstr(fname, sizeof(fname), STRING_PTR(fp), STRING_LEN(fp))) {
- *ret = 0;
- }
- if (ftocstr(fmode, sizeof(fmode), STRING_PTR(mode),
- STRING_LEN(mode))) {
- *ret = 0;
- }
-
- *xdrid = xdropen(NULL, fname, fmode);
- if (*xdrid == 0)
- *ret = 0;
- else
- *ret = 1;
-}
-
-/*___________________________________________________________________________
- |
- | what follows are the C routines for opening, closing xdr streams
- | and the routine to read/write compressed coordinates together
- | with some routines to assist in this task (those are marked
- | static and cannot be called from user programs)
-*/
-#define MAXABS INT_MAX-2
-
-#ifndef MIN
-#define MIN(x,y) ((x) < (y) ? (x):(y))
-#endif
-#ifndef MAX
-#define MAX(x,y) ((x) > (y) ? (x):(y))
-#endif
-#ifndef SQR
-#define SQR(x) ((x)*(x))
-#endif
-static int magicints[] = {
- 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 8, 10, 12, 16, 20, 25, 32, 40, 50, 64,
- 80, 101, 128, 161, 203, 256, 322, 406, 512, 645,
- 812, 1024, 1290, 1625, 2048, 2580, 3250, 4096, 5060, 6501,
- 8192, 10321, 13003, 16384, 20642, 26007, 32768, 41285, 52015, 65536,
- 82570, 104031, 131072, 165140, 208063, 262144, 330280, 416127, 524287, 660561,
- 832255, 1048576, 1321122, 1664510, 2097152, 2642245, 3329021, 4194304, 5284491, 6658042,
- 8388607, 10568983, 13316085, 16777216 };
-
-#define FIRSTIDX 9
-/* note that magicints[FIRSTIDX-1] == 0 */
-#define LASTIDX (sizeof(magicints) / sizeof(*magicints))
-
-
-/*__________________________________________________________________________
- |
- | xdropen - open xdr file
- |
- | This versions differs from xdrstdio_create, because I need to know
- | the state of the file (read or write) so I can use xdr3dfcoord
- | in eigther read or write mode, and the file descriptor
- | so I can close the file (something xdr_destroy doesn't do).
- |
-*/
-
-int xdropen(XDR *xdrs, const char *filename, const char *type) {
- static int init_done = 0;
- enum xdr_op lmode;
- int xdrid;
-
- if (init_done == 0) {
- for (xdrid = 1; xdrid < MAXID; xdrid++) {
- xdridptr[xdrid] = NULL;
- }
- init_done = 1;
- }
- xdrid = 1;
- while (xdrid < MAXID && xdridptr[xdrid] != NULL) {
- xdrid++;
- }
- if (xdrid == MAXID) {
- return 0;
- }
- if (*type == 'w' || *type == 'W') {
- type = "w+";
- lmode = XDR_ENCODE;
- } else {
- type = "r";
- lmode = XDR_DECODE;
- }
- xdrfiles[xdrid] = fopen(filename, type);
- if (xdrfiles[xdrid] == NULL) {
- xdrs = NULL;
- return 0;
- }
- xdrmodes[xdrid] = *type;
- /* next test isn't usefull in the case of C language
- * but is used for the Fortran interface
- * (C users are expected to pass the address of an already allocated
- * XDR staructure)
- */
- if (xdrs == NULL) {
- xdridptr[xdrid] = (XDR *) malloc(sizeof(XDR));
- xdrstdio_create(xdridptr[xdrid], xdrfiles[xdrid], lmode);
- } else {
- xdridptr[xdrid] = xdrs;
- xdrstdio_create(xdrs, xdrfiles[xdrid], lmode);
- }
- return xdrid;
-}
-
-/*_________________________________________________________________________
- |
- | xdrclose - close a xdr file
- |
- | This will flush the xdr buffers, and destroy the xdr stream.
- | It also closes the associated file descriptor (this is *not*
- | done by xdr_destroy).
- |
-*/
-
-int xdrclose(XDR *xdrs) {
- int xdrid;
-
- if (xdrs == NULL) {
- fprintf(stderr, "xdrclose: passed a NULL pointer\n");
- exit(1);
- }
- for (xdrid = 1; xdrid < MAXID; xdrid++) {
- if (xdridptr[xdrid] == xdrs) {
-
- xdr_destroy(xdrs);
- fclose(xdrfiles[xdrid]);
- xdridptr[xdrid] = NULL;
- return 1;
- }
- }
- fprintf(stderr, "xdrclose: no such open xdr file\n");
- exit(1);
-
-}
-
-/*____________________________________________________________________________
- |
- | sendbits - encode num into buf using the specified number of bits
- |
- | This routines appends the value of num to the bits already present in
- | the array buf. You need to give it the number of bits to use and you
- | better make sure that this number of bits is enough to hold the value
- | Also num must be positive.
- |
-*/
-
-static void sendbits(int buf[], int num_of_bits, int num) {
-
- unsigned int cnt, lastbyte;
- int lastbits;
- unsigned char * cbuf;
-
- cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf);
- cnt = (unsigned int) buf[0];
- lastbits = buf[1];
- lastbyte =(unsigned int) buf[2];
- while (num_of_bits >= 8) {
- lastbyte = (lastbyte << 8) | ((num >> (num_of_bits -8)) /* & 0xff*/);
- cbuf[cnt++] = lastbyte >> lastbits;
- num_of_bits -= 8;
- }
- if (num_of_bits > 0) {
- lastbyte = (lastbyte << num_of_bits) | num;
- lastbits += num_of_bits;
- if (lastbits >= 8) {
- lastbits -= 8;
- cbuf[cnt++] = lastbyte >> lastbits;
- }
- }
- buf[0] = cnt;
- buf[1] = lastbits;
- buf[2] = lastbyte;
- if (lastbits>0) {
- cbuf[cnt] = lastbyte << (8 - lastbits);
- }
-}
-
-/*_________________________________________________________________________
- |
- | sizeofint - calculate bitsize of an integer
- |
- | return the number of bits needed to store an integer with given max size
- |
-*/
-
-static int sizeofint(const int size) {
- unsigned int num = 1;
- int num_of_bits = 0;
-
- while (size >= num && num_of_bits < 32) {
- num_of_bits++;
- num <<= 1;
- }
- return num_of_bits;
-}
-
-/*___________________________________________________________________________
- |
- | sizeofints - calculate 'bitsize' of compressed ints
- |
- | given the number of small unsigned integers and the maximum value
- | return the number of bits needed to read or write them with the
- | routines receiveints and sendints. You need this parameter when
- | calling these routines. Note that for many calls I can use
- | the variable 'smallidx' which is exactly the number of bits, and
- | So I don't need to call 'sizeofints for those calls.
-*/
-
-static int sizeofints( const int num_of_ints, unsigned int sizes[]) {
- int i, num;
- unsigned int num_of_bytes, num_of_bits, bytes[32], bytecnt, tmp;
- num_of_bytes = 1;
- bytes[0] = 1;
- num_of_bits = 0;
- for (i=0; i < num_of_ints; i++) {
- tmp = 0;
- for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) {
- tmp = bytes[bytecnt] * sizes[i] + tmp;
- bytes[bytecnt] = tmp & 0xff;
- tmp >>= 8;
- }
- while (tmp != 0) {
- bytes[bytecnt++] = tmp & 0xff;
- tmp >>= 8;
- }
- num_of_bytes = bytecnt;
- }
- num = 1;
- num_of_bytes--;
- while (bytes[num_of_bytes] >= num) {
- num_of_bits++;
- num *= 2;
- }
- return num_of_bits + num_of_bytes * 8;
-
-}
-
-/*____________________________________________________________________________
- |
- | sendints - send a small set of small integers in compressed format
- |
- | this routine is used internally by xdr3dfcoord, to send a set of
- | small integers to the buffer.
- | Multiplication with fixed (specified maximum ) sizes is used to get
- | to one big, multibyte integer. Allthough the routine could be
- | modified to handle sizes bigger than 16777216, or more than just
- | a few integers, this is not done, because the gain in compression
- | isn't worth the effort. Note that overflowing the multiplication
- | or the byte buffer (32 bytes) is unchecked and causes bad results.
- |
- */
-
-static void sendints(int buf[], const int num_of_ints, const int num_of_bits,
- unsigned int sizes[], unsigned int nums[]) {
-
- int i;
- unsigned int bytes[32], num_of_bytes, bytecnt, tmp;
-
- tmp = nums[0];
- num_of_bytes = 0;
- do {
- bytes[num_of_bytes++] = tmp & 0xff;
- tmp >>= 8;
- } while (tmp != 0);
-
- for (i = 1; i < num_of_ints; i++) {
- if (nums[i] >= sizes[i]) {
- fprintf(stderr,"major breakdown in sendints num %d doesn't "
- "match size %d\n", nums[i], sizes[i]);
- exit(1);
- }
- /* use one step multiply */
- tmp = nums[i];
- for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) {
- tmp = bytes[bytecnt] * sizes[i] + tmp;
- bytes[bytecnt] = tmp & 0xff;
- tmp >>= 8;
- }
- while (tmp != 0) {
- bytes[bytecnt++] = tmp & 0xff;
- tmp >>= 8;
- }
- num_of_bytes = bytecnt;
- }
- if (num_of_bits >= num_of_bytes * 8) {
- for (i = 0; i < num_of_bytes; i++) {
- sendbits(buf, 8, bytes[i]);
- }
- sendbits(buf, num_of_bits - num_of_bytes * 8, 0);
- } else {
- for (i = 0; i < num_of_bytes-1; i++) {
- sendbits(buf, 8, bytes[i]);
- }
- sendbits(buf, num_of_bits- (num_of_bytes -1) * 8, bytes[i]);
- }
-}
-
-
-/*___________________________________________________________________________
- |
- | receivebits - decode number from buf using specified number of bits
- |
- | extract the number of bits from the array buf and construct an integer
- | from it. Return that value.
- |
-*/
-
-static int receivebits(int buf[], int num_of_bits) {
-
- int cnt, num;
- unsigned int lastbits, lastbyte;
- unsigned char * cbuf;
- int mask = (1 << num_of_bits) -1;
-
- cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf);
- cnt = buf[0];
- lastbits = (unsigned int) buf[1];
- lastbyte = (unsigned int) buf[2];
-
- num = 0;
- while (num_of_bits >= 8) {
- lastbyte = ( lastbyte << 8 ) | cbuf[cnt++];
- num |= (lastbyte >> lastbits) << (num_of_bits - 8);
- num_of_bits -=8;
- }
- if (num_of_bits > 0) {
- if (lastbits < num_of_bits) {
- lastbits += 8;
- lastbyte = (lastbyte << 8) | cbuf[cnt++];
- }
- lastbits -= num_of_bits;
- num |= (lastbyte >> lastbits) & ((1 << num_of_bits) -1);
- }
- num &= mask;
- buf[0] = cnt;
- buf[1] = lastbits;
- buf[2] = lastbyte;
- return num;
-}
-
-/*____________________________________________________________________________
- |
- | receiveints - decode 'small' integers from the buf array
- |
- | this routine is the inverse from sendints() and decodes the small integers
- | written to buf by calculating the remainder and doing divisions with
- | the given sizes[]. You need to specify the total number of bits to be
- | used from buf in num_of_bits.
- |
-*/
-
-static void receiveints(int buf[], const int num_of_ints, int num_of_bits,
- unsigned int sizes[], int nums[]) {
- int bytes[32];
- int i, j, num_of_bytes, p, num;
-
- bytes[1] = bytes[2] = bytes[3] = 0;
- num_of_bytes = 0;
- while (num_of_bits > 8) {
- bytes[num_of_bytes++] = receivebits(buf, 8);
- num_of_bits -= 8;
- }
- if (num_of_bits > 0) {
- bytes[num_of_bytes++] = receivebits(buf, num_of_bits);
- }
- for (i = num_of_ints-1; i > 0; i--) {
- num = 0;
- for (j = num_of_bytes-1; j >=0; j--) {
- num = (num << 8) | bytes[j];
- p = num / sizes[i];
- bytes[j] = p;
- num = num - p * sizes[i];
- }
- nums[i] = num;
- }
- nums[0] = bytes[0] | (bytes[1] << 8) | (bytes[2] << 16) | (bytes[3] << 24);
-}
-
-/*____________________________________________________________________________
- |
- | xdr3dfcoord - read or write compressed 3d coordinates to xdr file.
- |
- | this routine reads or writes (depending on how you opened the file with
- | xdropen() ) a large number of 3d coordinates (stored in *fp).
- | The number of coordinates triplets to write is given by *size. On
- | read this number may be zero, in which case it reads as many as were written
- | or it may specify the number if triplets to read (which should match the
- | number written).
- | Compression is achieved by first converting all floating numbers to integer
- | using multiplication by *precision and rounding to the nearest integer.
- | Then the minimum and maximum value are calculated to determine the range.
- | The limited range of integers so found, is used to compress the coordinates.
- | In addition the differences between succesive coordinates is calculated.
- | If the difference happens to be 'small' then only the difference is saved,
- | compressing the data even more. The notion of 'small' is changed dynamically
- | and is enlarged or reduced whenever needed or possible.
- | Extra compression is achieved in the case of GROMOS and coordinates of
- | water molecules. GROMOS first writes out the Oxygen position, followed by
- | the two hydrogens. In order to make the differences smaller (and thereby
- | compression the data better) the order is changed into first one hydrogen
- | then the oxygen, followed by the other hydrogen. This is rather special, but
- | it shouldn't harm in the general case.
- |
- */
-
-int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) {
-
-
- static int *ip = NULL;
- static int oldsize;
- static int *buf;
-
- int minint[3], maxint[3], mindiff, *lip, diff;
- int lint1, lint2, lint3, oldlint1, oldlint2, oldlint3, smallidx;
- int minidx, maxidx;
- unsigned sizeint[3], sizesmall[3], bitsizeint[3], size3, *luip;
- int flag, k;
- int small, smaller, larger, i, is_small, is_smaller, run, prevrun;
- float *lfp, lf;
- int tmp, *thiscoord, prevcoord[3];
- unsigned int tmpcoord[30];
-
- int bufsize, xdrid, lsize;
- unsigned int bitsize;
- float inv_precision;
- int errval = 1;
-
- /* find out if xdrs is opened for reading or for writing */
- xdrid = 0;
- while (xdridptr[xdrid] != xdrs) {
- xdrid++;
- if (xdrid >= MAXID) {
- fprintf(stderr, "xdr error. no open xdr stream\n");
- exit (1);
- }
- }
- if (xdrmodes[xdrid] == 'w') {
-
- /* xdrs is open for writing */
-
- if (xdr_int(xdrs, size) == 0)
- return 0;
- size3 = *size * 3;
- /* when the number of coordinates is small, don't try to compress; just
- * write them as floats using xdr_vector
- */
- if (*size <= 9 ) {
- return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp),
- (xdrproc_t)xdr_float));
- }
-
- xdr_float(xdrs, precision);
- if (ip == NULL) {
- ip = (int *)malloc(size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)malloc(bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- } else if (*size > oldsize) {
- ip = (int *)realloc(ip, size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)realloc(buf, bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- }
- /* buf[0-2] are special and do not contain actual data */
- buf[0] = buf[1] = buf[2] = 0;
- minint[0] = minint[1] = minint[2] = INT_MAX;
- maxint[0] = maxint[1] = maxint[2] = INT_MIN;
- prevrun = -1;
- lfp = fp;
- lip = ip;
- mindiff = INT_MAX;
- oldlint1 = oldlint2 = oldlint3 = 0;
- while(lfp < fp + size3 ) {
- /* find nearest integer */
- if (*lfp >= 0.0)
- lf = *lfp * *precision + 0.5;
- else
- lf = *lfp * *precision - 0.5;
- if (fabs(lf) > MAXABS) {
- /* scaling would cause overflow */
- errval = 0;
- }
- lint1 = lf;
- if (lint1 < minint[0]) minint[0] = lint1;
- if (lint1 > maxint[0]) maxint[0] = lint1;
- *lip++ = lint1;
- lfp++;
- if (*lfp >= 0.0)
- lf = *lfp * *precision + 0.5;
- else
- lf = *lfp * *precision - 0.5;
- if (fabs(lf) > MAXABS) {
- /* scaling would cause overflow */
- errval = 0;
- }
- lint2 = lf;
- if (lint2 < minint[1]) minint[1] = lint2;
- if (lint2 > maxint[1]) maxint[1] = lint2;
- *lip++ = lint2;
- lfp++;
- if (*lfp >= 0.0)
- lf = *lfp * *precision + 0.5;
- else
- lf = *lfp * *precision - 0.5;
- if (fabs(lf) > MAXABS) {
- /* scaling would cause overflow */
- errval = 0;
- }
- lint3 = lf;
- if (lint3 < minint[2]) minint[2] = lint3;
- if (lint3 > maxint[2]) maxint[2] = lint3;
- *lip++ = lint3;
- lfp++;
- diff = abs(oldlint1-lint1)+abs(oldlint2-lint2)+abs(oldlint3-lint3);
- if (diff < mindiff && lfp > fp + 3)
- mindiff = diff;
- oldlint1 = lint1;
- oldlint2 = lint2;
- oldlint3 = lint3;
- }
- xdr_int(xdrs, &(minint[0]));
- xdr_int(xdrs, &(minint[1]));
- xdr_int(xdrs, &(minint[2]));
-
- xdr_int(xdrs, &(maxint[0]));
- xdr_int(xdrs, &(maxint[1]));
- xdr_int(xdrs, &(maxint[2]));
-
- if ((float)maxint[0] - (float)minint[0] >= MAXABS ||
- (float)maxint[1] - (float)minint[1] >= MAXABS ||
- (float)maxint[2] - (float)minint[2] >= MAXABS) {
- /* turning value in unsigned by subtracting minint
- * would cause overflow
- */
- errval = 0;
- }
- sizeint[0] = maxint[0] - minint[0]+1;
- sizeint[1] = maxint[1] - minint[1]+1;
- sizeint[2] = maxint[2] - minint[2]+1;
-
- /* check if one of the sizes is to big to be multiplied */
- if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) {
- bitsizeint[0] = sizeofint(sizeint[0]);
- bitsizeint[1] = sizeofint(sizeint[1]);
- bitsizeint[2] = sizeofint(sizeint[2]);
- bitsize = 0; /* flag the use of large sizes */
- } else {
- bitsize = sizeofints(3, sizeint);
- }
- lip = ip;
- luip = (unsigned int *) ip;
- smallidx = FIRSTIDX;
- while (smallidx < LASTIDX && magicints[smallidx] < mindiff) {
- smallidx++;
- }
- xdr_int(xdrs, &smallidx);
- maxidx = MIN(LASTIDX, smallidx + 8) ;
- minidx = maxidx - 8; /* often this equal smallidx */
- smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2;
- small = magicints[smallidx] / 2;
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx];
- larger = magicints[maxidx] / 2;
- i = 0;
- while (i < *size) {
- is_small = 0;
- thiscoord = (int *)(luip) + i * 3;
- if (smallidx < maxidx && i >= 1 &&
- abs(thiscoord[0] - prevcoord[0]) < larger &&
- abs(thiscoord[1] - prevcoord[1]) < larger &&
- abs(thiscoord[2] - prevcoord[2]) < larger) {
- is_smaller = 1;
- } else if (smallidx > minidx) {
- is_smaller = -1;
- } else {
- is_smaller = 0;
- }
- if (i + 1 < *size) {
- if (abs(thiscoord[0] - thiscoord[3]) < small &&
- abs(thiscoord[1] - thiscoord[4]) < small &&
- abs(thiscoord[2] - thiscoord[5]) < small) {
- /* interchange first with second atom for better
- * compression of water molecules
- */
- tmp = thiscoord[0]; thiscoord[0] = thiscoord[3];
- thiscoord[3] = tmp;
- tmp = thiscoord[1]; thiscoord[1] = thiscoord[4];
- thiscoord[4] = tmp;
- tmp = thiscoord[2]; thiscoord[2] = thiscoord[5];
- thiscoord[5] = tmp;
- is_small = 1;
- }
-
- }
- tmpcoord[0] = thiscoord[0] - minint[0];
- tmpcoord[1] = thiscoord[1] - minint[1];
- tmpcoord[2] = thiscoord[2] - minint[2];
- if (bitsize == 0) {
- sendbits(buf, bitsizeint[0], tmpcoord[0]);
- sendbits(buf, bitsizeint[1], tmpcoord[1]);
- sendbits(buf, bitsizeint[2], tmpcoord[2]);
- } else {
- sendints(buf, 3, bitsize, sizeint, tmpcoord);
- }
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
- thiscoord = thiscoord + 3;
- i++;
-
- run = 0;
- if (is_small == 0 && is_smaller == -1)
- is_smaller = 0;
- while (is_small && run < 8*3) {
- if (is_smaller == -1 && (
- SQR(thiscoord[0] - prevcoord[0]) +
- SQR(thiscoord[1] - prevcoord[1]) +
- SQR(thiscoord[2] - prevcoord[2]) >= smaller * smaller)) {
- is_smaller = 0;
- }
-
- tmpcoord[run++] = thiscoord[0] - prevcoord[0] + small;
- tmpcoord[run++] = thiscoord[1] - prevcoord[1] + small;
- tmpcoord[run++] = thiscoord[2] - prevcoord[2] + small;
-
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
-
- i++;
- thiscoord = thiscoord + 3;
- is_small = 0;
- if (i < *size &&
- abs(thiscoord[0] - prevcoord[0]) < small &&
- abs(thiscoord[1] - prevcoord[1]) < small &&
- abs(thiscoord[2] - prevcoord[2]) < small) {
- is_small = 1;
- }
- }
- if (run != prevrun || is_smaller != 0) {
- prevrun = run;
- sendbits(buf, 1, 1); /* flag the change in run-length */
- sendbits(buf, 5, run+is_smaller+1);
- } else {
- sendbits(buf, 1, 0); /* flag the fact that runlength did not change */
- }
- for (k=0; k < run; k+=3) {
- sendints(buf, 3, smallidx, sizesmall, &tmpcoord[k]);
- }
- if (is_smaller != 0) {
- smallidx += is_smaller;
- if (is_smaller < 0) {
- small = smaller;
- smaller = magicints[smallidx-1] / 2;
- } else {
- smaller = small;
- small = magicints[smallidx] / 2;
- }
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx];
- }
- }
- if (buf[1] != 0) buf[0]++;;
- xdr_int(xdrs, &(buf[0])); /* buf[0] holds the length in bytes */
- return errval * (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0]));
- } else {
-
- /* xdrs is open for reading */
-
- if (xdr_int(xdrs, &lsize) == 0)
- return 0;
- if (*size != 0 && lsize != *size) {
- fprintf(stderr, "wrong number of coordinates in xdr3dfcoor; "
- "%d arg vs %d in file", *size, lsize);
- }
- *size = lsize;
- size3 = *size * 3;
- if (*size <= 9) {
- return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp),
- (xdrproc_t)xdr_float));
- }
- xdr_float(xdrs, precision);
- if (ip == NULL) {
- ip = (int *)malloc(size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)malloc(bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- } else if (*size > oldsize) {
- ip = (int *)realloc(ip, size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)realloc(buf, bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- }
- buf[0] = buf[1] = buf[2] = 0;
-
- xdr_int(xdrs, &(minint[0]));
- xdr_int(xdrs, &(minint[1]));
- xdr_int(xdrs, &(minint[2]));
-
- xdr_int(xdrs, &(maxint[0]));
- xdr_int(xdrs, &(maxint[1]));
- xdr_int(xdrs, &(maxint[2]));
-
- sizeint[0] = maxint[0] - minint[0]+1;
- sizeint[1] = maxint[1] - minint[1]+1;
- sizeint[2] = maxint[2] - minint[2]+1;
-
- /* check if one of the sizes is to big to be multiplied */
- if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) {
- bitsizeint[0] = sizeofint(sizeint[0]);
- bitsizeint[1] = sizeofint(sizeint[1]);
- bitsizeint[2] = sizeofint(sizeint[2]);
- bitsize = 0; /* flag the use of large sizes */
- } else {
- bitsize = sizeofints(3, sizeint);
- }
-
- xdr_int(xdrs, &smallidx);
- maxidx = MIN(LASTIDX, smallidx + 8) ;
- minidx = maxidx - 8; /* often this equal smallidx */
- smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2;
- small = magicints[smallidx] / 2;
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ;
- larger = magicints[maxidx];
-
- /* buf[0] holds the length in bytes */
-
- if (xdr_int(xdrs, &(buf[0])) == 0)
- return 0;
- if (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0]) == 0)
- return 0;
- buf[0] = buf[1] = buf[2] = 0;
-
- lfp = fp;
- inv_precision = 1.0 / * precision;
- run = 0;
- i = 0;
- lip = ip;
- while ( i < lsize ) {
- thiscoord = (int *)(lip) + i * 3;
-
- if (bitsize == 0) {
- thiscoord[0] = receivebits(buf, bitsizeint[0]);
- thiscoord[1] = receivebits(buf, bitsizeint[1]);
- thiscoord[2] = receivebits(buf, bitsizeint[2]);
- } else {
- receiveints(buf, 3, bitsize, sizeint, thiscoord);
- }
-
- i++;
- thiscoord[0] += minint[0];
- thiscoord[1] += minint[1];
- thiscoord[2] += minint[2];
-
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
-
-
- flag = receivebits(buf, 1);
- is_smaller = 0;
- if (flag == 1) {
- run = receivebits(buf, 5);
- is_smaller = run % 3;
- run -= is_smaller;
- is_smaller--;
- }
- if (run > 0) {
- thiscoord += 3;
- for (k = 0; k < run; k+=3) {
- receiveints(buf, 3, smallidx, sizesmall, thiscoord);
- i++;
- thiscoord[0] += prevcoord[0] - small;
- thiscoord[1] += prevcoord[1] - small;
- thiscoord[2] += prevcoord[2] - small;
- if (k == 0) {
- /* interchange first with second atom for better
- * compression of water molecules
- */
- tmp = thiscoord[0]; thiscoord[0] = prevcoord[0];
- prevcoord[0] = tmp;
- tmp = thiscoord[1]; thiscoord[1] = prevcoord[1];
- prevcoord[1] = tmp;
- tmp = thiscoord[2]; thiscoord[2] = prevcoord[2];
- prevcoord[2] = tmp;
- *lfp++ = prevcoord[0] * inv_precision;
- *lfp++ = prevcoord[1] * inv_precision;
- *lfp++ = prevcoord[2] * inv_precision;
- } else {
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
- }
- *lfp++ = thiscoord[0] * inv_precision;
- *lfp++ = thiscoord[1] * inv_precision;
- *lfp++ = thiscoord[2] * inv_precision;
- }
- } else {
- *lfp++ = thiscoord[0] * inv_precision;
- *lfp++ = thiscoord[1] * inv_precision;
- *lfp++ = thiscoord[2] * inv_precision;
- }
- smallidx += is_smaller;
- if (is_smaller < 0) {
- small = smaller;
- if (smallidx > FIRSTIDX) {
- smaller = magicints[smallidx - 1] /2;
- } else {
- smaller = 0;
- }
- } else if (is_smaller > 0) {
- smaller = small;
- small = magicints[smallidx] / 2;
- }
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ;
- }
- }
- return 1;
-}
-
-
-
+++ /dev/null
-/*
- * Sun RPC is a product of Sun Microsystems, Inc. and is provided for
- * unrestricted use provided that this legend is included on all tape
- * media and as a part of the software program in whole or part. Users
- * may copy or modify Sun RPC without charge, but are not authorized
- * to license or distribute it to anyone else except as part of a product or
- * program developed by the user.
- *
- * SUN RPC IS PROVIDED AS IS WITH NO WARRANTIES OF ANY KIND INCLUDING THE
- * WARRANTIES OF DESIGN, MERCHANTIBILITY AND FITNESS FOR A PARTICULAR
- * PURPOSE, OR ARISING FROM A COURSE OF DEALING, USAGE OR TRADE PRACTICE.
- *
- * Sun RPC is provided with no support and without any obligation on the
- * part of Sun Microsystems, Inc. to assist in its use, correction,
- * modification or enhancement.
- *
- * SUN MICROSYSTEMS, INC. SHALL HAVE NO LIABILITY WITH RESPECT TO THE
- * INFRINGEMENT OF COPYRIGHTS, TRADE SECRETS OR ANY PATENTS BY SUN RPC
- * OR ANY PART THEREOF.
- *
- * In no event will Sun Microsystems, Inc. be liable for any lost revenue
- * or profits or other special, indirect and consequential damages, even if
- * Sun has been advised of the possibility of such damages.
- *
- * Sun Microsystems, Inc.
- * 2550 Garcia Avenue
- * Mountain View, California 94043
- */
-/* fixincludes should not add extern "C" to this file */
-/*
- * Rpc additions to <sys/types.h>
- */
-#ifndef _RPC_TYPES_H
-#define _RPC_TYPES_H 1
-
-typedef int bool_t;
-typedef int enum_t;
-/* This needs to be changed to uint32_t in the future */
-typedef unsigned long rpcprog_t;
-typedef unsigned long rpcvers_t;
-typedef unsigned long rpcproc_t;
-typedef unsigned long rpcprot_t;
-typedef unsigned long rpcport_t;
-
-#define __dontcare__ -1
-
-#ifndef FALSE
-# define FALSE (0)
-#endif
-
-#ifndef TRUE
-# define TRUE (1)
-#endif
-
-#ifndef NULL
-# define NULL 0
-#endif
-
-#include <stdlib.h> /* For malloc decl. */
-#define mem_alloc(bsize) malloc(bsize)
-/*
- * XXX: This must not use the second argument, or code in xdr_array.c needs
- * to be modified.
- */
-#define mem_free(ptr, bsize) free(ptr)
-
-#ifndef makedev /* ie, we haven't already included it */
-#include <sys/types.h>
-#endif
-
-#ifndef __u_char_defined
-typedef __u_char u_char;
-typedef __u_short u_short;
-typedef __u_int u_int;
-typedef __u_long u_long;
-typedef __quad_t quad_t;
-typedef __u_quad_t u_quad_t;
-typedef __fsid_t fsid_t;
-# define __u_char_defined
-#endif
-#ifndef __daddr_t_defined
-typedef __daddr_t daddr_t;
-typedef __caddr_t caddr_t;
-# define __daddr_t_defined
-#endif
-
-#include <sys/time.h>
-#include <sys/param.h>
-
-#include <netinet/in.h>
-
-#ifndef INADDR_LOOPBACK
-#define INADDR_LOOPBACK (u_long)0x7F000001
-#endif
-#ifndef MAXHOSTNAMELEN
-#define MAXHOSTNAMELEN 64
-#endif
-
-#endif /* rpc/types.h */
+++ /dev/null
-divert(-1)
-undefine(`len')
-#
-# append an underscore to FORTRAN function names
-#
-define(`FUNCTION',`$1_')
-#
-# FORTRAN character strings are passed as follows:
-# a pointer to the base of the string is passed in the normal
-# argument list, and the length is passed by value as an extra
-# argument, after all of the other arguments.
-#
-define(`ARGS',`($1`'undivert(1))')
-define(`SAVE',`divert(1)$1`'divert(0)')
-define(`STRING_ARG',`$1_ptr`'SAVE(`, $1_len')')
-define(`STRING_ARG_DECL',`char * $1_ptr; int $1_len')
-define(`STRING_LEN',`$1_len')
-define(`STRING_PTR',`$1_ptr')
-divert(0)
+++ /dev/null
-# define INTUSE(name) name
-# define INTDEF(name)
-/* @(#)xdr.c 2.1 88/07/29 4.0 RPCSRC */
-/*
- * Sun RPC is a product of Sun Microsystems, Inc. and is provided for
- * unrestricted use provided that this legend is included on all tape
- * media and as a part of the software program in whole or part. Users
- * may copy or modify Sun RPC without charge, but are not authorized
- * to license or distribute it to anyone else except as part of a product or
- * program developed by the user.
- *
- * SUN RPC IS PROVIDED AS IS WITH NO WARRANTIES OF ANY KIND INCLUDING THE
- * WARRANTIES OF DESIGN, MERCHANTIBILITY AND FITNESS FOR A PARTICULAR
- * PURPOSE, OR ARISING FROM A COURSE OF DEALING, USAGE OR TRADE PRACTICE.
- *
- * Sun RPC is provided with no support and without any obligation on the
- * part of Sun Microsystems, Inc. to assist in its use, correction,
- * modification or enhancement.
- *
- * SUN MICROSYSTEMS, INC. SHALL HAVE NO LIABILITY WITH RESPECT TO THE
- * INFRINGEMENT OF COPYRIGHTS, TRADE SECRETS OR ANY PATENTS BY SUN RPC
- * OR ANY PART THEREOF.
- *
- * In no event will Sun Microsystems, Inc. be liable for any lost revenue
- * or profits or other special, indirect and consequential damages, even if
- * Sun has been advised of the possibility of such damages.
- *
- * Sun Microsystems, Inc.
- * 2550 Garcia Avenue
- * Mountain View, California 94043
- */
-#if !defined(lint) && defined(SCCSIDS)
-static char sccsid[] = "@(#)xdr.c 1.35 87/08/12";
-#endif
-
-/*
- * xdr.c, Generic XDR routines implementation.
- *
- * Copyright (C) 1986, Sun Microsystems, Inc.
- *
- * These are the "generic" xdr routines used to serialize and de-serialize
- * most common data items. See xdr.h for more info on the interface to
- * xdr.
- */
-
-#include <stdio.h>
-#include <limits.h>
-#include <string.h>
-#include <libintl.h>
-
-#include "types.h"
-#include "xdr.h"
-
-#ifdef USE_IN_LIBIO
-# include <wchar.h>
-#endif
-
-/*
- * constants specific to the xdr "protocol"
- */
-#define XDR_FALSE ((long) 0)
-#define XDR_TRUE ((long) 1)
-#define LASTUNSIGNED ((u_int) 0-1)
-
-/*
- * for unit alignment
- */
-static const char xdr_zero[BYTES_PER_XDR_UNIT] = {0, 0, 0, 0};
-
-/*
- * Free a data structure using XDR
- * Not a filter, but a convenient utility nonetheless
- */
-void
-xdr_free (xdrproc_t proc, char *objp)
-{
- XDR x;
-
- x.x_op = XDR_FREE;
- (*proc) (&x, objp);
-}
-
-/*
- * XDR nothing
- */
-bool_t
-xdr_void (void)
-{
- return TRUE;
-}
-INTDEF(xdr_void)
-
-/*
- * XDR integers
- */
-bool_t
-xdr_int (XDR *xdrs, int *ip)
-{
-
-#if INT_MAX < LONG_MAX
- long l;
-
- switch (xdrs->x_op)
- {
- case XDR_ENCODE:
- l = (long) *ip;
- return XDR_PUTLONG (xdrs, &l);
-
- case XDR_DECODE:
- if (!XDR_GETLONG (xdrs, &l))
- {
- return FALSE;
- }
- *ip = (int) l;
- case XDR_FREE:
- return TRUE;
- }
- return FALSE;
-#elif INT_MAX == LONG_MAX
- return INTUSE(xdr_long) (xdrs, (long *) ip);
-#elif INT_MAX == SHRT_MAX
- return INTUSE(xdr_short) (xdrs, (short *) ip);
-#else
-#error unexpected integer sizes in_xdr_int()
-#endif
-}
-INTDEF(xdr_int)
-
-/*
- * XDR unsigned integers
- */
-bool_t
-xdr_u_int (XDR *xdrs, u_int *up)
-{
-#if UINT_MAX < ULONG_MAX
- long l;
-
- switch (xdrs->x_op)
- {
- case XDR_ENCODE:
- l = (u_long) * up;
- return XDR_PUTLONG (xdrs, &l);
-
- case XDR_DECODE:
- if (!XDR_GETLONG (xdrs, &l))
- {
- return FALSE;
- }
- *up = (u_int) (u_long) l;
- case XDR_FREE:
- return TRUE;
- }
- return FALSE;
-#elif UINT_MAX == ULONG_MAX
- return INTUSE(xdr_u_long) (xdrs, (u_long *) up);
-#elif UINT_MAX == USHRT_MAX
- return INTUSE(xdr_short) (xdrs, (short *) up);
-#else
-#error unexpected integer sizes in_xdr_u_int()
-#endif
-}
-INTDEF(xdr_u_int)
-
-/*
- * XDR long integers
- * The definition of xdr_long() is kept for backward
- * compatibility. Instead xdr_int() should be used.
- */
-bool_t
-xdr_long (XDR *xdrs, long *lp)
-{
-
- if (xdrs->x_op == XDR_ENCODE
- && (sizeof (int32_t) == sizeof (long)
- || (int32_t) *lp == *lp))
- return XDR_PUTLONG (xdrs, lp);
-
- if (xdrs->x_op == XDR_DECODE)
- return XDR_GETLONG (xdrs, lp);
-
- if (xdrs->x_op == XDR_FREE)
- return TRUE;
-
- return FALSE;
-}
-INTDEF(xdr_long)
-
-/*
- * XDR unsigned long integers
- * The definition of xdr_u_long() is kept for backward
- * compatibility. Instead xdr_u_int() should be used.
- */
-bool_t
-xdr_u_long (XDR *xdrs, u_long *ulp)
-{
- switch (xdrs->x_op)
- {
- case XDR_DECODE:
- {
- long int tmp;
-
- if (XDR_GETLONG (xdrs, &tmp) == FALSE)
- return FALSE;
-
- *ulp = (uint32_t) tmp;
- return TRUE;
- }
-
- case XDR_ENCODE:
- if (sizeof (uint32_t) != sizeof (u_long)
- && (uint32_t) *ulp != *ulp)
- return FALSE;
-
- return XDR_PUTLONG (xdrs, (long *) ulp);
-
- case XDR_FREE:
- return TRUE;
- }
- return FALSE;
-}
-INTDEF(xdr_u_long)
-
-/*
- * XDR hyper integers
- * same as xdr_u_hyper - open coded to save a proc call!
- */
-bool_t
-xdr_hyper (XDR *xdrs, quad_t *llp)
-{
- long int t1, t2;
-
- if (xdrs->x_op == XDR_ENCODE)
- {
- t1 = (long) ((*llp) >> 32);
- t2 = (long) (*llp);
- return (XDR_PUTLONG(xdrs, &t1) && XDR_PUTLONG(xdrs, &t2));
- }
-
- if (xdrs->x_op == XDR_DECODE)
- {
- if (!XDR_GETLONG(xdrs, &t1) || !XDR_GETLONG(xdrs, &t2))
- return FALSE;
- *llp = ((quad_t) t1) << 32;
- *llp |= (uint32_t) t2;
- return TRUE;
- }
-
- if (xdrs->x_op == XDR_FREE)
- return TRUE;
-
- return FALSE;
-}
-INTDEF(xdr_hyper)
-
-
-/*
- * XDR hyper integers
- * same as xdr_hyper - open coded to save a proc call!
- */
-bool_t
-xdr_u_hyper (XDR *xdrs, u_quad_t *ullp)
-{
- long int t1, t2;
-
- if (xdrs->x_op == XDR_ENCODE)
- {
- t1 = (unsigned long) ((*ullp) >> 32);
- t2 = (unsigned long) (*ullp);
- return (XDR_PUTLONG(xdrs, &t1) && XDR_PUTLONG(xdrs, &t2));
- }
-
- if (xdrs->x_op == XDR_DECODE)
- {
- if (!XDR_GETLONG(xdrs, &t1) || !XDR_GETLONG(xdrs, &t2))
- return FALSE;
- *ullp = ((u_quad_t) t1) << 32;
- *ullp |= (uint32_t) t2;
- return TRUE;
- }
-
- if (xdrs->x_op == XDR_FREE)
- return TRUE;
-
- return FALSE;
-}
-INTDEF(xdr_u_hyper)
-
-bool_t
-xdr_longlong_t (XDR *xdrs, quad_t *llp)
-{
- return INTUSE(xdr_hyper) (xdrs, llp);
-}
-
-bool_t
-xdr_u_longlong_t (XDR *xdrs, u_quad_t *ullp)
-{
- return INTUSE(xdr_u_hyper) (xdrs, ullp);
-}
-
-/*
- * XDR short integers
- */
-bool_t
-xdr_short (XDR *xdrs, short *sp)
-{
- long l;
-
- switch (xdrs->x_op)
- {
- case XDR_ENCODE:
- l = (long) *sp;
- return XDR_PUTLONG (xdrs, &l);
-
- case XDR_DECODE:
- if (!XDR_GETLONG (xdrs, &l))
- {
- return FALSE;
- }
- *sp = (short) l;
- return TRUE;
-
- case XDR_FREE:
- return TRUE;
- }
- return FALSE;
-}
-INTDEF(xdr_short)
-
-/*
- * XDR unsigned short integers
- */
-bool_t
-xdr_u_short (XDR *xdrs, u_short *usp)
-{
- long l;
-
- switch (xdrs->x_op)
- {
- case XDR_ENCODE:
- l = (u_long) * usp;
- return XDR_PUTLONG (xdrs, &l);
-
- case XDR_DECODE:
- if (!XDR_GETLONG (xdrs, &l))
- {
- return FALSE;
- }
- *usp = (u_short) (u_long) l;
- return TRUE;
-
- case XDR_FREE:
- return TRUE;
- }
- return FALSE;
-}
-INTDEF(xdr_u_short)
-
-
-/*
- * XDR a char
- */
-bool_t
-xdr_char (XDR *xdrs, char *cp)
-{
- int i;
-
- i = (*cp);
- if (!INTUSE(xdr_int) (xdrs, &i))
- {
- return FALSE;
- }
- *cp = i;
- return TRUE;
-}
-
-/*
- * XDR an unsigned char
- */
-bool_t
-xdr_u_char (XDR *xdrs, u_char *cp)
-{
- u_int u;
-
- u = (*cp);
- if (!INTUSE(xdr_u_int) (xdrs, &u))
- {
- return FALSE;
- }
- *cp = u;
- return TRUE;
-}
-
-/*
- * XDR booleans
- */
-bool_t
-xdr_bool (XDR *xdrs, bool_t *bp)
-{
- long lb;
-
- switch (xdrs->x_op)
- {
- case XDR_ENCODE:
- lb = *bp ? XDR_TRUE : XDR_FALSE;
- return XDR_PUTLONG (xdrs, &lb);
-
- case XDR_DECODE:
- if (!XDR_GETLONG (xdrs, &lb))
- {
- return FALSE;
- }
- *bp = (lb == XDR_FALSE) ? FALSE : TRUE;
- return TRUE;
-
- case XDR_FREE:
- return TRUE;
- }
- return FALSE;
-}
-INTDEF(xdr_bool)
-
-/*
- * XDR enumerations
- */
-bool_t
-xdr_enum (XDR *xdrs, enum_t *ep)
-{
- enum sizecheck
- {
- SIZEVAL
- }; /* used to find the size of an enum */
-
- /*
- * enums are treated as ints
- */
- if (sizeof (enum sizecheck) == 4)
- {
-#if INT_MAX < LONG_MAX
- long l;
-
- switch (xdrs->x_op)
- {
- case XDR_ENCODE:
- l = *ep;
- return XDR_PUTLONG (xdrs, &l);
-
- case XDR_DECODE:
- if (!XDR_GETLONG (xdrs, &l))
- {
- return FALSE;
- }
- *ep = l;
- case XDR_FREE:
- return TRUE;
-
- }
- return FALSE;
-#else
- return INTUSE(xdr_long) (xdrs, (long *) ep);
-#endif
- }
- else if (sizeof (enum sizecheck) == sizeof (short))
- {
- return INTUSE(xdr_short) (xdrs, (short *) ep);
- }
- else
- {
- return FALSE;
- }
-}
-INTDEF(xdr_enum)
-
-/*
- * XDR opaque data
- * Allows the specification of a fixed size sequence of opaque bytes.
- * cp points to the opaque object and cnt gives the byte length.
- */
-bool_t
-xdr_opaque (XDR *xdrs, caddr_t cp, u_int cnt)
-{
- u_int rndup;
- static char crud[BYTES_PER_XDR_UNIT];
-
- /*
- * if no data we are done
- */
- if (cnt == 0)
- return TRUE;
-
- /*
- * round byte count to full xdr units
- */
- rndup = cnt % BYTES_PER_XDR_UNIT;
- if (rndup > 0)
- rndup = BYTES_PER_XDR_UNIT - rndup;
-
- switch (xdrs->x_op)
- {
- case XDR_DECODE:
- if (!XDR_GETBYTES (xdrs, cp, cnt))
- {
- return FALSE;
- }
- if (rndup == 0)
- return TRUE;
- return XDR_GETBYTES (xdrs, (caddr_t)crud, rndup);
-
- case XDR_ENCODE:
- if (!XDR_PUTBYTES (xdrs, cp, cnt))
- {
- return FALSE;
- }
- if (rndup == 0)
- return TRUE;
- return XDR_PUTBYTES (xdrs, xdr_zero, rndup);
-
- case XDR_FREE:
- return TRUE;
- }
- return FALSE;
-}
-INTDEF(xdr_opaque)
-
-/*
- * XDR counted bytes
- * *cpp is a pointer to the bytes, *sizep is the count.
- * If *cpp is NULL maxsize bytes are allocated
- */
-bool_t
-xdr_bytes (xdrs, cpp, sizep, maxsize)
- XDR *xdrs;
- char **cpp;
- u_int *sizep;
- u_int maxsize;
-{
- char *sp = *cpp; /* sp is the actual string pointer */
- u_int nodesize;
-
- /*
- * first deal with the length since xdr bytes are counted
- */
- if (!INTUSE(xdr_u_int) (xdrs, sizep))
- {
- return FALSE;
- }
- nodesize = *sizep;
- if ((nodesize > maxsize) && (xdrs->x_op != XDR_FREE))
- {
- return FALSE;
- }
-
- /*
- * now deal with the actual bytes
- */
- switch (xdrs->x_op)
- {
- case XDR_DECODE:
- if (nodesize == 0)
- {
- return TRUE;
- }
- if (sp == NULL)
- {
- *cpp = sp = (char *) mem_alloc (nodesize);
- }
- if (sp == NULL)
- {
- fprintf (NULL, "%s", "xdr_bytes: out of memory\n");
- return FALSE;
- }
- /* fall into ... */
-
- case XDR_ENCODE:
- return INTUSE(xdr_opaque) (xdrs, sp, nodesize);
-
- case XDR_FREE:
- if (sp != NULL)
- {
- mem_free (sp, nodesize);
- *cpp = NULL;
- }
- return TRUE;
- }
- return FALSE;
-}
-INTDEF(xdr_bytes)
-
-/*
- * Implemented here due to commonality of the object.
- */
-bool_t
-xdr_netobj (xdrs, np)
- XDR *xdrs;
- struct netobj *np;
-{
-
- return INTUSE(xdr_bytes) (xdrs, &np->n_bytes, &np->n_len, MAX_NETOBJ_SZ);
-}
-INTDEF(xdr_netobj)
-
-/*
- * XDR a discriminated union
- * Support routine for discriminated unions.
- * You create an array of xdrdiscrim structures, terminated with
- * an entry with a null procedure pointer. The routine gets
- * the discriminant value and then searches the array of xdrdiscrims
- * looking for that value. It calls the procedure given in the xdrdiscrim
- * to handle the discriminant. If there is no specific routine a default
- * routine may be called.
- * If there is no specific or default routine an error is returned.
- */
-bool_t
-xdr_union (xdrs, dscmp, unp, choices, dfault)
- XDR *xdrs;
- enum_t *dscmp; /* enum to decide which arm to work on */
- char *unp; /* the union itself */
- const struct xdr_discrim *choices; /* [value, xdr proc] for each arm */
- xdrproc_t dfault; /* default xdr routine */
-{
- enum_t dscm;
-
- /*
- * we deal with the discriminator; it's an enum
- */
- if (!INTUSE(xdr_enum) (xdrs, dscmp))
- {
- return FALSE;
- }
- dscm = *dscmp;
-
- /*
- * search choices for a value that matches the discriminator.
- * if we find one, execute the xdr routine for that value.
- */
- for (; choices->proc != NULL_xdrproc_t; choices++)
- {
- if (choices->value == dscm)
- return (*(choices->proc)) (xdrs, unp, LASTUNSIGNED);
- }
-
- /*
- * no match - execute the default xdr routine if there is one
- */
- return ((dfault == NULL_xdrproc_t) ? FALSE :
- (*dfault) (xdrs, unp, LASTUNSIGNED));
-}
-INTDEF(xdr_union)
-
-
-/*
- * Non-portable xdr primitives.
- * Care should be taken when moving these routines to new architectures.
- */
-
-
-/*
- * XDR null terminated ASCII strings
- * xdr_string deals with "C strings" - arrays of bytes that are
- * terminated by a NULL character. The parameter cpp references a
- * pointer to storage; If the pointer is null, then the necessary
- * storage is allocated. The last parameter is the max allowed length
- * of the string as specified by a protocol.
- */
-bool_t
-xdr_string (xdrs, cpp, maxsize)
- XDR *xdrs;
- char **cpp;
- u_int maxsize;
-{
- char *sp = *cpp; /* sp is the actual string pointer */
- u_int size;
- u_int nodesize;
-
- /*
- * first deal with the length since xdr strings are counted-strings
- */
- switch (xdrs->x_op)
- {
- case XDR_FREE:
- if (sp == NULL)
- {
- return TRUE; /* already free */
- }
- /* fall through... */
- case XDR_ENCODE:
- if (sp == NULL)
- return FALSE;
- size = strlen (sp);
- break;
- case XDR_DECODE:
- break;
- }
- if (!INTUSE(xdr_u_int) (xdrs, &size))
- {
- return FALSE;
- }
- if (size > maxsize)
- {
- return FALSE;
- }
- nodesize = size + 1;
- if (nodesize == 0)
- {
- /* This means an overflow. It a bug in the caller which
- provided a too large maxsize but nevertheless catch it
- here. */
- return FALSE;
- }
-
- /*
- * now deal with the actual bytes
- */
- switch (xdrs->x_op)
- {
- case XDR_DECODE:
- if (sp == NULL)
- *cpp = sp = (char *) mem_alloc (nodesize);
- if (sp == NULL)
- {
- fprintf (NULL, "%s", "xdr_string: out of memory\n");
- return FALSE;
- }
- sp[size] = 0;
- /* fall into ... */
-
- case XDR_ENCODE:
- return INTUSE(xdr_opaque) (xdrs, sp, size);
-
- case XDR_FREE:
- mem_free (sp, nodesize);
- *cpp = NULL;
- return TRUE;
- }
- return FALSE;
-}
-INTDEF(xdr_string)
-
-/*
- * Wrapper for xdr_string that can be called directly from
- * routines like clnt_call
- */
-bool_t
-xdr_wrapstring (xdrs, cpp)
- XDR *xdrs;
- char **cpp;
-{
- if (INTUSE(xdr_string) (xdrs, cpp, LASTUNSIGNED))
- {
- return TRUE;
- }
- return FALSE;
-}
+++ /dev/null
-/*
- * Sun RPC is a product of Sun Microsystems, Inc. and is provided for
- * unrestricted use provided that this legend is included on all tape
- * media and as a part of the software program in whole or part. Users
- * may copy or modify Sun RPC without charge, but are not authorized
- * to license or distribute it to anyone else except as part of a product or
- * program developed by the user.
- *
- * SUN RPC IS PROVIDED AS IS WITH NO WARRANTIES OF ANY KIND INCLUDING THE
- * WARRANTIES OF DESIGN, MERCHANTIBILITY AND FITNESS FOR A PARTICULAR
- * PURPOSE, OR ARISING FROM A COURSE OF DEALING, USAGE OR TRADE PRACTICE.
- *
- * Sun RPC is provided with no support and without any obligation on the
- * part of Sun Microsystems, Inc. to assist in its use, correction,
- * modification or enhancement.
- *
- * SUN MICROSYSTEMS, INC. SHALL HAVE NO LIABILITY WITH RESPECT TO THE
- * INFRINGEMENT OF COPYRIGHTS, TRADE SECRETS OR ANY PATENTS BY SUN RPC
- * OR ANY PART THEREOF.
- *
- * In no event will Sun Microsystems, Inc. be liable for any lost revenue
- * or profits or other special, indirect and consequential damages, even if
- * Sun has been advised of the possibility of such damages.
- *
- * Sun Microsystems, Inc.
- * 2550 Garcia Avenue
- * Mountain View, California 94043
- */
-
-/*
- * xdr.h, External Data Representation Serialization Routines.
- *
- * Copyright (C) 1984, Sun Microsystems, Inc.
- */
-
-#ifndef _RPC_XDR_H
-#define _RPC_XDR_H 1
-
-#include <features.h>
-#include <sys/types.h>
-#include "types.h"
-
-/* We need FILE. */
-#include <stdio.h>
-
-__BEGIN_DECLS
-
-/*
- * XDR provides a conventional way for converting between C data
- * types and an external bit-string representation. Library supplied
- * routines provide for the conversion on built-in C data types. These
- * routines and utility routines defined here are used to help implement
- * a type encode/decode routine for each user-defined type.
- *
- * Each data type provides a single procedure which takes two arguments:
- *
- * bool_t
- * xdrproc(xdrs, argresp)
- * XDR *xdrs;
- * <type> *argresp;
- *
- * xdrs is an instance of a XDR handle, to which or from which the data
- * type is to be converted. argresp is a pointer to the structure to be
- * converted. The XDR handle contains an operation field which indicates
- * which of the operations (ENCODE, DECODE * or FREE) is to be performed.
- *
- * XDR_DECODE may allocate space if the pointer argresp is null. This
- * data can be freed with the XDR_FREE operation.
- *
- * We write only one procedure per data type to make it easy
- * to keep the encode and decode procedures for a data type consistent.
- * In many cases the same code performs all operations on a user defined type,
- * because all the hard work is done in the component type routines.
- * decode as a series of calls on the nested data types.
- */
-
-/*
- * Xdr operations. XDR_ENCODE causes the type to be encoded into the
- * stream. XDR_DECODE causes the type to be extracted from the stream.
- * XDR_FREE can be used to release the space allocated by an XDR_DECODE
- * request.
- */
-enum xdr_op {
- XDR_ENCODE = 0,
- XDR_DECODE = 1,
- XDR_FREE = 2
-};
-
-/*
- * This is the number of bytes per unit of external data.
- */
-#define BYTES_PER_XDR_UNIT (4)
-/*
- * This only works if the above is a power of 2. But it's defined to be
- * 4 by the appropriate RFCs. So it will work. And it's normally quicker
- * than the old routine.
- */
-#if 1
-#define RNDUP(x) (((x) + BYTES_PER_XDR_UNIT - 1) & ~(BYTES_PER_XDR_UNIT - 1))
-#else /* this is the old routine */
-#define RNDUP(x) ((((x) + BYTES_PER_XDR_UNIT - 1) / BYTES_PER_XDR_UNIT) \
- * BYTES_PER_XDR_UNIT)
-#endif
-
-/*
- * The XDR handle.
- * Contains operation which is being applied to the stream,
- * an operations vector for the particular implementation (e.g. see xdr_mem.c),
- * and two private fields for the use of the particular implementation.
- */
-typedef struct XDR XDR;
-struct XDR
- {
- enum xdr_op x_op; /* operation; fast additional param */
- struct xdr_ops
- {
- bool_t (*x_getlong) (XDR *__xdrs, long *__lp);
- /* get a long from underlying stream */
- bool_t (*x_putlong) (XDR *__xdrs, __const long *__lp);
- /* put a long to " */
- bool_t (*x_getbytes) (XDR *__xdrs, caddr_t __addr, u_int __len);
- /* get some bytes from " */
- bool_t (*x_putbytes) (XDR *__xdrs, __const char *__addr, u_int __len);
- /* put some bytes to " */
- u_int (*x_getpostn) (__const XDR *__xdrs);
- /* returns bytes off from beginning */
- bool_t (*x_setpostn) (XDR *__xdrs, u_int __pos);
- /* lets you reposition the stream */
- int32_t *(*x_inline) (XDR *__xdrs, u_int __len);
- /* buf quick ptr to buffered data */
- void (*x_destroy) (XDR *__xdrs);
- /* free privates of this xdr_stream */
- bool_t (*x_getint32) (XDR *__xdrs, int32_t *__ip);
- /* get a int from underlying stream */
- bool_t (*x_putint32) (XDR *__xdrs, __const int32_t *__ip);
- /* put a int to " */
- }
- *x_ops;
- caddr_t x_public; /* users' data */
- caddr_t x_private; /* pointer to private data */
- caddr_t x_base; /* private used for position info */
- u_int x_handy; /* extra private word */
- };
-
-/*
- * A xdrproc_t exists for each data type which is to be encoded or decoded.
- *
- * The second argument to the xdrproc_t is a pointer to an opaque pointer.
- * The opaque pointer generally points to a structure of the data type
- * to be decoded. If this pointer is 0, then the type routines should
- * allocate dynamic storage of the appropriate size and return it.
- * bool_t (*xdrproc_t)(XDR *, caddr_t *);
- */
-typedef bool_t (*xdrproc_t) (XDR *, void *,...);
-
-
-/*
- * Operations defined on a XDR handle
- *
- * XDR *xdrs;
- * int32_t *int32p;
- * long *longp;
- * caddr_t addr;
- * u_int len;
- * u_int pos;
- */
-#define XDR_GETINT32(xdrs, int32p) \
- (*(xdrs)->x_ops->x_getint32)(xdrs, int32p)
-#define xdr_getint32(xdrs, int32p) \
- (*(xdrs)->x_ops->x_getint32)(xdrs, int32p)
-
-#define XDR_PUTINT32(xdrs, int32p) \
- (*(xdrs)->x_ops->x_putint32)(xdrs, int32p)
-#define xdr_putint32(xdrs, int32p) \
- (*(xdrs)->x_ops->x_putint32)(xdrs, int32p)
-
-#define XDR_GETLONG(xdrs, longp) \
- (*(xdrs)->x_ops->x_getlong)(xdrs, longp)
-#define xdr_getlong(xdrs, longp) \
- (*(xdrs)->x_ops->x_getlong)(xdrs, longp)
-
-#define XDR_PUTLONG(xdrs, longp) \
- (*(xdrs)->x_ops->x_putlong)(xdrs, longp)
-#define xdr_putlong(xdrs, longp) \
- (*(xdrs)->x_ops->x_putlong)(xdrs, longp)
-
-#define XDR_GETBYTES(xdrs, addr, len) \
- (*(xdrs)->x_ops->x_getbytes)(xdrs, addr, len)
-#define xdr_getbytes(xdrs, addr, len) \
- (*(xdrs)->x_ops->x_getbytes)(xdrs, addr, len)
-
-#define XDR_PUTBYTES(xdrs, addr, len) \
- (*(xdrs)->x_ops->x_putbytes)(xdrs, addr, len)
-#define xdr_putbytes(xdrs, addr, len) \
- (*(xdrs)->x_ops->x_putbytes)(xdrs, addr, len)
-
-#define XDR_GETPOS(xdrs) \
- (*(xdrs)->x_ops->x_getpostn)(xdrs)
-#define xdr_getpos(xdrs) \
- (*(xdrs)->x_ops->x_getpostn)(xdrs)
-
-#define XDR_SETPOS(xdrs, pos) \
- (*(xdrs)->x_ops->x_setpostn)(xdrs, pos)
-#define xdr_setpos(xdrs, pos) \
- (*(xdrs)->x_ops->x_setpostn)(xdrs, pos)
-
-#define XDR_INLINE(xdrs, len) \
- (*(xdrs)->x_ops->x_inline)(xdrs, len)
-#define xdr_inline(xdrs, len) \
- (*(xdrs)->x_ops->x_inline)(xdrs, len)
-
-#define XDR_DESTROY(xdrs) \
- do { \
- if ((xdrs)->x_ops->x_destroy) \
- (*(xdrs)->x_ops->x_destroy)(xdrs); \
- } while (0)
-#define xdr_destroy(xdrs) \
- do { \
- if ((xdrs)->x_ops->x_destroy) \
- (*(xdrs)->x_ops->x_destroy)(xdrs); \
- } while (0)
-
-/*
- * Support struct for discriminated unions.
- * You create an array of xdrdiscrim structures, terminated with
- * a entry with a null procedure pointer. The xdr_union routine gets
- * the discriminant value and then searches the array of structures
- * for a matching value. If a match is found the associated xdr routine
- * is called to handle that part of the union. If there is
- * no match, then a default routine may be called.
- * If there is no match and no default routine it is an error.
- */
-#define NULL_xdrproc_t ((xdrproc_t)0)
-struct xdr_discrim
-{
- int value;
- xdrproc_t proc;
-};
-
-/*
- * Inline routines for fast encode/decode of primitive data types.
- * Caveat emptor: these use single memory cycles to get the
- * data from the underlying buffer, and will fail to operate
- * properly if the data is not aligned. The standard way to use these
- * is to say:
- * if ((buf = XDR_INLINE(xdrs, count)) == NULL)
- * return (FALSE);
- * <<< macro calls >>>
- * where ``count'' is the number of bytes of data occupied
- * by the primitive data types.
- *
- * N.B. and frozen for all time: each data type here uses 4 bytes
- * of external representation.
- */
-
-#define IXDR_GET_INT32(buf) ((int32_t)ntohl((uint32_t)*(buf)++))
-#define IXDR_PUT_INT32(buf, v) (*(buf)++ = (int32_t)htonl((uint32_t)(v)))
-#define IXDR_GET_U_INT32(buf) ((uint32_t)IXDR_GET_INT32(buf))
-#define IXDR_PUT_U_INT32(buf, v) IXDR_PUT_INT32(buf, (int32_t)(v))
-
-/* WARNING: The IXDR_*_LONG defines are removed by Sun for new platforms
- * and shouldn't be used any longer. Code which use this defines or longs
- * in the RPC code will not work on 64bit Solaris platforms !
- */
-#define IXDR_GET_LONG(buf) ((long)IXDR_GET_U_INT32(buf))
-#define IXDR_PUT_LONG(buf, v) ((long)IXDR_PUT_INT32(buf, (long)(v)))
-#define IXDR_GET_U_LONG(buf) ((u_long)IXDR_GET_LONG(buf))
-#define IXDR_PUT_U_LONG(buf, v) IXDR_PUT_LONG(buf, (long)(v))
-
-
-#define IXDR_GET_BOOL(buf) ((bool_t)IXDR_GET_LONG(buf))
-#define IXDR_GET_ENUM(buf, t) ((t)IXDR_GET_LONG(buf))
-#define IXDR_GET_SHORT(buf) ((short)IXDR_GET_LONG(buf))
-#define IXDR_GET_U_SHORT(buf) ((u_short)IXDR_GET_LONG(buf))
-
-#define IXDR_PUT_BOOL(buf, v) IXDR_PUT_LONG(buf, (long)(v))
-#define IXDR_PUT_ENUM(buf, v) IXDR_PUT_LONG(buf, (long)(v))
-#define IXDR_PUT_SHORT(buf, v) IXDR_PUT_LONG(buf, (long)(v))
-#define IXDR_PUT_U_SHORT(buf, v) IXDR_PUT_LONG(buf, (long)(v))
-
-/*
- * These are the "generic" xdr routines.
- * None of these can have const applied because it's not possible to
- * know whether the call is a read or a write to the passed parameter
- * also, the XDR structure is always updated by some of these calls.
- */
-extern bool_t xdr_void (void) __THROW;
-extern bool_t xdr_short (XDR *__xdrs, short *__sp) __THROW;
-extern bool_t xdr_u_short (XDR *__xdrs, u_short *__usp) __THROW;
-extern bool_t xdr_int (XDR *__xdrs, int *__ip) __THROW;
-extern bool_t xdr_u_int (XDR *__xdrs, u_int *__up) __THROW;
-extern bool_t xdr_long (XDR *__xdrs, long *__lp) __THROW;
-extern bool_t xdr_u_long (XDR *__xdrs, u_long *__ulp) __THROW;
-extern bool_t xdr_hyper (XDR *__xdrs, quad_t *__llp) __THROW;
-extern bool_t xdr_u_hyper (XDR *__xdrs, u_quad_t *__ullp) __THROW;
-extern bool_t xdr_longlong_t (XDR *__xdrs, quad_t *__llp) __THROW;
-extern bool_t xdr_u_longlong_t (XDR *__xdrs, u_quad_t *__ullp) __THROW;
-extern bool_t xdr_int8_t (XDR *__xdrs, int8_t *__ip) __THROW;
-extern bool_t xdr_uint8_t (XDR *__xdrs, uint8_t *__up) __THROW;
-extern bool_t xdr_int16_t (XDR *__xdrs, int16_t *__ip) __THROW;
-extern bool_t xdr_uint16_t (XDR *__xdrs, uint16_t *__up) __THROW;
-extern bool_t xdr_int32_t (XDR *__xdrs, int32_t *__ip) __THROW;
-extern bool_t xdr_uint32_t (XDR *__xdrs, uint32_t *__up) __THROW;
-extern bool_t xdr_int64_t (XDR *__xdrs, int64_t *__ip) __THROW;
-extern bool_t xdr_uint64_t (XDR *__xdrs, uint64_t *__up) __THROW;
-extern bool_t xdr_quad_t (XDR *__xdrs, quad_t *__ip) __THROW;
-extern bool_t xdr_u_quad_t (XDR *__xdrs, u_quad_t *__up) __THROW;
-extern bool_t xdr_bool (XDR *__xdrs, bool_t *__bp) __THROW;
-extern bool_t xdr_enum (XDR *__xdrs, enum_t *__ep) __THROW;
-extern bool_t xdr_array (XDR * _xdrs, caddr_t *__addrp, u_int *__sizep,
- u_int __maxsize, u_int __elsize, xdrproc_t __elproc)
- __THROW;
-extern bool_t xdr_bytes (XDR *__xdrs, char **__cpp, u_int *__sizep,
- u_int __maxsize) __THROW;
-extern bool_t xdr_opaque (XDR *__xdrs, caddr_t __cp, u_int __cnt) __THROW;
-extern bool_t xdr_string (XDR *__xdrs, char **__cpp, u_int __maxsize) __THROW;
-extern bool_t xdr_union (XDR *__xdrs, enum_t *__dscmp, char *__unp,
- __const struct xdr_discrim *__choices,
- xdrproc_t dfault) __THROW;
-extern bool_t xdr_char (XDR *__xdrs, char *__cp) __THROW;
-extern bool_t xdr_u_char (XDR *__xdrs, u_char *__cp) __THROW;
-extern bool_t xdr_vector (XDR *__xdrs, char *__basep, u_int __nelem,
- u_int __elemsize, xdrproc_t __xdr_elem) __THROW;
-extern bool_t xdr_float (XDR *__xdrs, float *__fp) __THROW;
-extern bool_t xdr_double (XDR *__xdrs, double *__dp) __THROW;
-extern bool_t xdr_reference (XDR *__xdrs, caddr_t *__xpp, u_int __size,
- xdrproc_t __proc) __THROW;
-extern bool_t xdr_pointer (XDR *__xdrs, char **__objpp,
- u_int __obj_size, xdrproc_t __xdr_obj) __THROW;
-extern bool_t xdr_wrapstring (XDR *__xdrs, char **__cpp) __THROW;
-extern u_long xdr_sizeof (xdrproc_t, void *) __THROW;
-
-/*
- * Common opaque bytes objects used by many rpc protocols;
- * declared here due to commonality.
- */
-#define MAX_NETOBJ_SZ 1024
-struct netobj
-{
- u_int n_len;
- char *n_bytes;
-};
-typedef struct netobj netobj;
-extern bool_t xdr_netobj (XDR *__xdrs, struct netobj *__np) __THROW;
-
-/*
- * These are the public routines for the various implementations of
- * xdr streams.
- */
-
-/* XDR using memory buffers */
-extern void xdrmem_create (XDR *__xdrs, __const caddr_t __addr,
- u_int __size, enum xdr_op __xop) __THROW;
-
-/* XDR using stdio library */
-extern void xdrstdio_create (XDR *__xdrs, FILE *__file, enum xdr_op __xop)
- __THROW;
-
-/* XDR pseudo records for tcp */
-extern void xdrrec_create (XDR *__xdrs, u_int __sendsize,
- u_int __recvsize, caddr_t __tcp_handle,
- int (*__readit) (char *, char *, int),
- int (*__writeit) (char *, char *, int)) __THROW;
-
-/* make end of xdr record */
-extern bool_t xdrrec_endofrecord (XDR *__xdrs, bool_t __sendnow) __THROW;
-
-/* move to beginning of next record */
-extern bool_t xdrrec_skiprecord (XDR *__xdrs) __THROW;
-
-/* true if no more input */
-extern bool_t xdrrec_eof (XDR *__xdrs) __THROW;
-
-/* free memory buffers for xdr */
-extern void xdr_free (xdrproc_t __proc, char *__objp) __THROW;
-
-__END_DECLS
-
-#endif /* rpc/xdr.h */
+++ /dev/null
-# define INTUSE(name) name
-# define INTDEF(name)
-/* @(#)xdr_array.c 2.1 88/07/29 4.0 RPCSRC */
-/*
- * Sun RPC is a product of Sun Microsystems, Inc. and is provided for
- * unrestricted use provided that this legend is included on all tape
- * media and as a part of the software program in whole or part. Users
- * may copy or modify Sun RPC without charge, but are not authorized
- * to license or distribute it to anyone else except as part of a product or
- * program developed by the user.
- *
- * SUN RPC IS PROVIDED AS IS WITH NO WARRANTIES OF ANY KIND INCLUDING THE
- * WARRANTIES OF DESIGN, MERCHANTIBILITY AND FITNESS FOR A PARTICULAR
- * PURPOSE, OR ARISING FROM A COURSE OF DEALING, USAGE OR TRADE PRACTICE.
- *
- * Sun RPC is provided with no support and without any obligation on the
- * part of Sun Microsystems, Inc. to assist in its use, correction,
- * modification or enhancement.
- *
- * SUN MICROSYSTEMS, INC. SHALL HAVE NO LIABILITY WITH RESPECT TO THE
- * INFRINGEMENT OF COPYRIGHTS, TRADE SECRETS OR ANY PATENTS BY SUN RPC
- * OR ANY PART THEREOF.
- *
- * In no event will Sun Microsystems, Inc. be liable for any lost revenue
- * or profits or other special, indirect and consequential damages, even if
- * Sun has been advised of the possibility of such damages.
- *
- * Sun Microsystems, Inc.
- * 2550 Garcia Avenue
- * Mountain View, California 94043
- */
-#if !defined(lint) && defined(SCCSIDS)
-static char sccsid[] = "@(#)xdr_array.c 1.10 87/08/11 Copyr 1984 Sun Micro";
-#endif
-
-/*
- * xdr_array.c, Generic XDR routines implementation.
- *
- * Copyright (C) 1984, Sun Microsystems, Inc.
- *
- * These are the "non-trivial" xdr primitives used to serialize and de-serialize
- * arrays. See xdr.h for more info on the interface to xdr.
- */
-
-#include <stdio.h>
-#include <string.h>
-#include "types.h"
-#include "xdr.h"
-#include <libintl.h>
-#include <limits.h>
-
-#ifdef USE_IN_LIBIO
-# include <wchar.h>
-#endif
-
-#define LASTUNSIGNED ((u_int)0-1)
-
-
-/*
- * XDR an array of arbitrary elements
- * *addrp is a pointer to the array, *sizep is the number of elements.
- * If addrp is NULL (*sizep * elsize) bytes are allocated.
- * elsize is the size (in bytes) of each element, and elproc is the
- * xdr procedure to call to handle each element of the array.
- */
-bool_t
-xdr_array (xdrs, addrp, sizep, maxsize, elsize, elproc)
- XDR *xdrs;
- caddr_t *addrp; /* array pointer */
- u_int *sizep; /* number of elements */
- u_int maxsize; /* max numberof elements */
- u_int elsize; /* size in bytes of each element */
- xdrproc_t elproc; /* xdr routine to handle each element */
-{
- u_int i;
- caddr_t target = *addrp;
- u_int c; /* the actual element count */
- bool_t stat = TRUE;
- u_int nodesize;
-
- /* like strings, arrays are really counted arrays */
- if (!INTUSE(xdr_u_int) (xdrs, sizep))
- {
- return FALSE;
- }
- c = *sizep;
- /*
- * XXX: Let the overflow possibly happen with XDR_FREE because mem_free()
- * doesn't actually use its second argument anyway.
- */
- if ((c > maxsize || c > UINT_MAX / elsize) && (xdrs->x_op != XDR_FREE))
- {
- return FALSE;
- }
- nodesize = c * elsize;
-
- /*
- * if we are deserializing, we may need to allocate an array.
- * We also save time by checking for a null array if we are freeing.
- */
- if (target == NULL)
- switch (xdrs->x_op)
- {
- case XDR_DECODE:
- if (c == 0)
- return TRUE;
- *addrp = target = mem_alloc (nodesize);
- if (target == NULL)
- {
- fprintf (stderr, "%s", "xdr_array: out of memory\n");
- return FALSE;
- }
- __bzero (target, nodesize);
- break;
-
- case XDR_FREE:
- return TRUE;
- default:
- break;
- }
-
- /*
- * now we xdr each element of array
- */
- for (i = 0; (i < c) && stat; i++)
- {
- stat = (*elproc) (xdrs, target, LASTUNSIGNED);
- target += elsize;
- }
-
- /*
- * the array may need freeing
- */
- if (xdrs->x_op == XDR_FREE)
- {
- mem_free (*addrp, nodesize);
- *addrp = NULL;
- }
- return stat;
-}
-INTDEF(xdr_array)
-
-/*
- * xdr_vector():
- *
- * XDR a fixed length array. Unlike variable-length arrays,
- * the storage of fixed length arrays is static and unfreeable.
- * > basep: base of the array
- * > size: size of the array
- * > elemsize: size of each element
- * > xdr_elem: routine to XDR each element
- */
-bool_t
-xdr_vector (xdrs, basep, nelem, elemsize, xdr_elem)
- XDR *xdrs;
- char *basep;
- u_int nelem;
- u_int elemsize;
- xdrproc_t xdr_elem;
-{
- u_int i;
- char *elptr;
-
- elptr = basep;
- for (i = 0; i < nelem; i++)
- {
- if (!(*xdr_elem) (xdrs, elptr, LASTUNSIGNED))
- {
- return FALSE;
- }
- elptr += elemsize;
- }
- return TRUE;
-}
+++ /dev/null
-/* @(#)xdr_float.c 2.1 88/07/29 4.0 RPCSRC */
-/*
- * Sun RPC is a product of Sun Microsystems, Inc. and is provided for
- * unrestricted use provided that this legend is included on all tape
- * media and as a part of the software program in whole or part. Users
- * may copy or modify Sun RPC without charge, but are not authorized
- * to license or distribute it to anyone else except as part of a product or
- * program developed by the user.
- *
- * SUN RPC IS PROVIDED AS IS WITH NO WARRANTIES OF ANY KIND INCLUDING THE
- * WARRANTIES OF DESIGN, MERCHANTIBILITY AND FITNESS FOR A PARTICULAR
- * PURPOSE, OR ARISING FROM A COURSE OF DEALING, USAGE OR TRADE PRACTICE.
- *
- * Sun RPC is provided with no support and without any obligation on the
- * part of Sun Microsystems, Inc. to assist in its use, correction,
- * modification or enhancement.
- *
- * SUN MICROSYSTEMS, INC. SHALL HAVE NO LIABILITY WITH RESPECT TO THE
- * INFRINGEMENT OF COPYRIGHTS, TRADE SECRETS OR ANY PATENTS BY SUN RPC
- * OR ANY PART THEREOF.
- *
- * In no event will Sun Microsystems, Inc. be liable for any lost revenue
- * or profits or other special, indirect and consequential damages, even if
- * Sun has been advised of the possibility of such damages.
- *
- * Sun Microsystems, Inc.
- * 2550 Garcia Avenue
- * Mountain View, California 94043
- */
-#if !defined(lint) && defined(SCCSIDS)
-static char sccsid[] = "@(#)xdr_float.c 1.12 87/08/11 Copyr 1984 Sun Micro";
-#endif
-
-/*
- * xdr_float.c, Generic XDR routines implementation.
- *
- * Copyright (C) 1984, Sun Microsystems, Inc.
- *
- * These are the "floating point" xdr routines used to (de)serialize
- * most common data items. See xdr.h for more info on the interface to
- * xdr.
- */
-
-#include <stdio.h>
-#include <endian.h>
-
-#include "types.h"
-#include "xdr.h"
-
-/*
- * NB: Not portable.
- * This routine works on Suns (Sky / 68000's) and Vaxen.
- */
-
-#define LSW (__FLOAT_WORD_ORDER == __BIG_ENDIAN)
-
-#ifdef vax
-
-/* What IEEE single precision floating point looks like on a Vax */
-struct ieee_single {
- unsigned int mantissa: 23;
- unsigned int exp : 8;
- unsigned int sign : 1;
-};
-
-/* Vax single precision floating point */
-struct vax_single {
- unsigned int mantissa1 : 7;
- unsigned int exp : 8;
- unsigned int sign : 1;
- unsigned int mantissa2 : 16;
-};
-
-#define VAX_SNG_BIAS 0x81
-#define IEEE_SNG_BIAS 0x7f
-
-static struct sgl_limits {
- struct vax_single s;
- struct ieee_single ieee;
-} sgl_limits[2] = {
- {{ 0x7f, 0xff, 0x0, 0xffff }, /* Max Vax */
- { 0x0, 0xff, 0x0 }}, /* Max IEEE */
- {{ 0x0, 0x0, 0x0, 0x0 }, /* Min Vax */
- { 0x0, 0x0, 0x0 }} /* Min IEEE */
-};
-#endif /* vax */
-
-bool_t
-xdr_float(xdrs, fp)
- XDR *xdrs;
- float *fp;
-{
-#ifdef vax
- struct ieee_single is;
- struct vax_single vs, *vsp;
- struct sgl_limits *lim;
- int i;
-#endif
- switch (xdrs->x_op) {
-
- case XDR_ENCODE:
-#ifdef vax
- vs = *((struct vax_single *)fp);
- for (i = 0, lim = sgl_limits;
- i < sizeof(sgl_limits)/sizeof(struct sgl_limits);
- i++, lim++) {
- if ((vs.mantissa2 == lim->s.mantissa2) &&
- (vs.exp == lim->s.exp) &&
- (vs.mantissa1 == lim->s.mantissa1)) {
- is = lim->ieee;
- goto shipit;
- }
- }
- is.exp = vs.exp - VAX_SNG_BIAS + IEEE_SNG_BIAS;
- is.mantissa = (vs.mantissa1 << 16) | vs.mantissa2;
- shipit:
- is.sign = vs.sign;
- return (XDR_PUTLONG(xdrs, (long *)&is));
-#else
- if (sizeof(float) == sizeof(long))
- return (XDR_PUTLONG(xdrs, (long *)fp));
- else if (sizeof(float) == sizeof(int)) {
- long tmp = *(int *)fp;
- return (XDR_PUTLONG(xdrs, &tmp));
- }
- break;
-#endif
-
- case XDR_DECODE:
-#ifdef vax
- vsp = (struct vax_single *)fp;
- if (!XDR_GETLONG(xdrs, (long *)&is))
- return (FALSE);
- for (i = 0, lim = sgl_limits;
- i < sizeof(sgl_limits)/sizeof(struct sgl_limits);
- i++, lim++) {
- if ((is.exp == lim->ieee.exp) &&
- (is.mantissa == lim->ieee.mantissa)) {
- *vsp = lim->s;
- goto doneit;
- }
- }
- vsp->exp = is.exp - IEEE_SNG_BIAS + VAX_SNG_BIAS;
- vsp->mantissa2 = is.mantissa;
- vsp->mantissa1 = (is.mantissa >> 16);
- doneit:
- vsp->sign = is.sign;
- return (TRUE);
-#else
- if (sizeof(float) == sizeof(long))
- return (XDR_GETLONG(xdrs, (long *)fp));
- else if (sizeof(float) == sizeof(int)) {
- long tmp;
- if (XDR_GETLONG(xdrs, &tmp)) {
- *(int *)fp = tmp;
- return (TRUE);
- }
- }
- break;
-#endif
-
- case XDR_FREE:
- return (TRUE);
- }
- return (FALSE);
-}
-
-/*
- * This routine works on Suns (Sky / 68000's) and Vaxen.
- */
-
-#ifdef vax
-/* What IEEE double precision floating point looks like on a Vax */
-struct ieee_double {
- unsigned int mantissa1 : 20;
- unsigned int exp : 11;
- unsigned int sign : 1;
- unsigned int mantissa2 : 32;
-};
-
-/* Vax double precision floating point */
-struct vax_double {
- unsigned int mantissa1 : 7;
- unsigned int exp : 8;
- unsigned int sign : 1;
- unsigned int mantissa2 : 16;
- unsigned int mantissa3 : 16;
- unsigned int mantissa4 : 16;
-};
-
-#define VAX_DBL_BIAS 0x81
-#define IEEE_DBL_BIAS 0x3ff
-#define MASK(nbits) ((1 << nbits) - 1)
-
-static struct dbl_limits {
- struct vax_double d;
- struct ieee_double ieee;
-} dbl_limits[2] = {
- {{ 0x7f, 0xff, 0x0, 0xffff, 0xffff, 0xffff }, /* Max Vax */
- { 0x0, 0x7ff, 0x0, 0x0 }}, /* Max IEEE */
- {{ 0x0, 0x0, 0x0, 0x0, 0x0, 0x0}, /* Min Vax */
- { 0x0, 0x0, 0x0, 0x0 }} /* Min IEEE */
-};
-
-#endif /* vax */
-
-
-bool_t
-xdr_double(xdrs, dp)
- XDR *xdrs;
- double *dp;
-{
-#ifdef vax
- struct ieee_double id;
- struct vax_double vd;
- register struct dbl_limits *lim;
- int i;
-#endif
-
- switch (xdrs->x_op) {
-
- case XDR_ENCODE:
-#ifdef vax
- vd = *((struct vax_double *)dp);
- for (i = 0, lim = dbl_limits;
- i < sizeof(dbl_limits)/sizeof(struct dbl_limits);
- i++, lim++) {
- if ((vd.mantissa4 == lim->d.mantissa4) &&
- (vd.mantissa3 == lim->d.mantissa3) &&
- (vd.mantissa2 == lim->d.mantissa2) &&
- (vd.mantissa1 == lim->d.mantissa1) &&
- (vd.exp == lim->d.exp)) {
- id = lim->ieee;
- goto shipit;
- }
- }
- id.exp = vd.exp - VAX_DBL_BIAS + IEEE_DBL_BIAS;
- id.mantissa1 = (vd.mantissa1 << 13) | (vd.mantissa2 >> 3);
- id.mantissa2 = ((vd.mantissa2 & MASK(3)) << 29) |
- (vd.mantissa3 << 13) |
- ((vd.mantissa4 >> 3) & MASK(13));
- shipit:
- id.sign = vd.sign;
- dp = (double *)&id;
-#endif
- if (2*sizeof(long) == sizeof(double)) {
- long *lp = (long *)dp;
- return (XDR_PUTLONG(xdrs, lp+!LSW) &&
- XDR_PUTLONG(xdrs, lp+LSW));
- } else if (2*sizeof(int) == sizeof(double)) {
- int *ip = (int *)dp;
- long tmp[2];
- tmp[0] = ip[!LSW];
- tmp[1] = ip[LSW];
- return (XDR_PUTLONG(xdrs, tmp) &&
- XDR_PUTLONG(xdrs, tmp+1));
- }
- break;
-
- case XDR_DECODE:
-#ifdef vax
- lp = (long *)&id;
- if (!XDR_GETLONG(xdrs, lp++) || !XDR_GETLONG(xdrs, lp))
- return (FALSE);
- for (i = 0, lim = dbl_limits;
- i < sizeof(dbl_limits)/sizeof(struct dbl_limits);
- i++, lim++) {
- if ((id.mantissa2 == lim->ieee.mantissa2) &&
- (id.mantissa1 == lim->ieee.mantissa1) &&
- (id.exp == lim->ieee.exp)) {
- vd = lim->d;
- goto doneit;
- }
- }
- vd.exp = id.exp - IEEE_DBL_BIAS + VAX_DBL_BIAS;
- vd.mantissa1 = (id.mantissa1 >> 13);
- vd.mantissa2 = ((id.mantissa1 & MASK(13)) << 3) |
- (id.mantissa2 >> 29);
- vd.mantissa3 = (id.mantissa2 >> 13);
- vd.mantissa4 = (id.mantissa2 << 3);
- doneit:
- vd.sign = id.sign;
- *dp = *((double *)&vd);
- return (TRUE);
-#else
- if (2*sizeof(long) == sizeof(double)) {
- long *lp = (long *)dp;
- return (XDR_GETLONG(xdrs, lp+!LSW) &&
- XDR_GETLONG(xdrs, lp+LSW));
- } else if (2*sizeof(int) == sizeof(double)) {
- int *ip = (int *)dp;
- long tmp[2];
- if (XDR_GETLONG(xdrs, tmp+!LSW) &&
- XDR_GETLONG(xdrs, tmp+LSW)) {
- ip[0] = tmp[0];
- ip[1] = tmp[1];
- return (TRUE);
- }
- }
- break;
-#endif
-
- case XDR_FREE:
- return (TRUE);
- }
- return (FALSE);
-}
+++ /dev/null
-/*
- * Sun RPC is a product of Sun Microsystems, Inc. and is provided for
- * unrestricted use provided that this legend is included on all tape
- * media and as a part of the software program in whole or part. Users
- * may copy or modify Sun RPC without charge, but are not authorized
- * to license or distribute it to anyone else except as part of a product or
- * program developed by the user.
- *
- * SUN RPC IS PROVIDED AS IS WITH NO WARRANTIES OF ANY KIND INCLUDING THE
- * WARRANTIES OF DESIGN, MERCHANTIBILITY AND FITNESS FOR A PARTICULAR
- * PURPOSE, OR ARISING FROM A COURSE OF DEALING, USAGE OR TRADE PRACTICE.
- *
- * Sun RPC is provided with no support and without any obligation on the
- * part of Sun Microsystems, Inc. to assist in its use, correction,
- * modification or enhancement.
- *
- * SUN MICROSYSTEMS, INC. SHALL HAVE NO LIABILITY WITH RESPECT TO THE
- * INFRINGEMENT OF COPYRIGHTS, TRADE SECRETS OR ANY PATENTS BY SUN RPC
- * OR ANY PART THEREOF.
- *
- * In no event will Sun Microsystems, Inc. be liable for any lost revenue
- * or profits or other special, indirect and consequential damages, even if
- * Sun has been advised of the possibility of such damages.
- *
- * Sun Microsystems, Inc.
- * 2550 Garcia Avenue
- * Mountain View, California 94043
- */
-
-/*
- * xdr_stdio.c, XDR implementation on standard i/o file.
- *
- * Copyright (C) 1984, Sun Microsystems, Inc.
- *
- * This set of routines implements a XDR on a stdio stream.
- * XDR_ENCODE serializes onto the stream, XDR_DECODE de-serializes
- * from the stream.
- */
-
-#include "types.h"
-#include <stdio.h>
-#include "xdr.h"
-
-#ifdef USE_IN_LIBIO
-# include <libio/iolibio.h>
-# define fflush(s) INTUSE(_IO_fflush) (s)
-# define fread(p, m, n, s) INTUSE(_IO_fread) (p, m, n, s)
-# define ftell(s) INTUSE(_IO_ftell) (s)
-# define fwrite(p, m, n, s) INTUSE(_IO_fwrite) (p, m, n, s)
-#endif
-
-static bool_t xdrstdio_getlong (XDR *, long *);
-static bool_t xdrstdio_putlong (XDR *, const long *);
-static bool_t xdrstdio_getbytes (XDR *, caddr_t, u_int);
-static bool_t xdrstdio_putbytes (XDR *, const char *, u_int);
-static u_int xdrstdio_getpos (const XDR *);
-static bool_t xdrstdio_setpos (XDR *, u_int);
-static int32_t *xdrstdio_inline (XDR *, u_int);
-static void xdrstdio_destroy (XDR *);
-static bool_t xdrstdio_getint32 (XDR *, int32_t *);
-static bool_t xdrstdio_putint32 (XDR *, const int32_t *);
-
-/*
- * Ops vector for stdio type XDR
- */
-static const struct xdr_ops xdrstdio_ops =
-{
- xdrstdio_getlong, /* deserialize a long int */
- xdrstdio_putlong, /* serialize a long int */
- xdrstdio_getbytes, /* deserialize counted bytes */
- xdrstdio_putbytes, /* serialize counted bytes */
- xdrstdio_getpos, /* get offset in the stream */
- xdrstdio_setpos, /* set offset in the stream */
- xdrstdio_inline, /* prime stream for inline macros */
- xdrstdio_destroy, /* destroy stream */
- xdrstdio_getint32, /* deserialize a int */
- xdrstdio_putint32 /* serialize a int */
-};
-
-/*
- * Initialize a stdio xdr stream.
- * Sets the xdr stream handle xdrs for use on the stream file.
- * Operation flag is set to op.
- */
-void
-xdrstdio_create (XDR *xdrs, FILE *file, enum xdr_op op)
-{
- xdrs->x_op = op;
- /* We have to add the const since the `struct xdr_ops' in `struct XDR'
- is not `const'. */
- xdrs->x_ops = (struct xdr_ops *) &xdrstdio_ops;
- xdrs->x_private = (caddr_t) file;
- xdrs->x_handy = 0;
- xdrs->x_base = 0;
-}
-
-/*
- * Destroy a stdio xdr stream.
- * Cleans up the xdr stream handle xdrs previously set up by xdrstdio_create.
- */
-static void
-xdrstdio_destroy (XDR *xdrs)
-{
- (void) fflush ((FILE *) xdrs->x_private);
- /* xx should we close the file ?? */
-};
-
-static bool_t
-xdrstdio_getlong (XDR *xdrs, long *lp)
-{
- u_int32_t mycopy;
-
- if (fread ((caddr_t) &mycopy, 4, 1, (FILE *) xdrs->x_private) != 1)
- return FALSE;
- *lp = (long) ntohl (mycopy);
- return TRUE;
-}
-
-static bool_t
-xdrstdio_putlong (XDR *xdrs, const long *lp)
-{
- int32_t mycopy = htonl ((u_int32_t) *lp);
-
- if (fwrite ((caddr_t) &mycopy, 4, 1, (FILE *) xdrs->x_private) != 1)
- return FALSE;
- return TRUE;
-}
-
-static bool_t
-xdrstdio_getbytes (XDR *xdrs, const caddr_t addr, u_int len)
-{
- if ((len != 0) && (fread (addr, (int) len, 1,
- (FILE *) xdrs->x_private) != 1))
- return FALSE;
- return TRUE;
-}
-
-static bool_t
-xdrstdio_putbytes (XDR *xdrs, const char *addr, u_int len)
-{
- if ((len != 0) && (fwrite (addr, (int) len, 1,
- (FILE *) xdrs->x_private) != 1))
- return FALSE;
- return TRUE;
-}
-
-static u_int
-xdrstdio_getpos (const XDR *xdrs)
-{
- return (u_int) ftell ((FILE *) xdrs->x_private);
-}
-
-static bool_t
-xdrstdio_setpos (XDR *xdrs, u_int pos)
-{
- return fseek ((FILE *) xdrs->x_private, (long) pos, 0) < 0 ? FALSE : TRUE;
-}
-
-static int32_t *
-xdrstdio_inline (XDR *xdrs, u_int len)
-{
- /*
- * Must do some work to implement this: must insure
- * enough data in the underlying stdio buffer,
- * that the buffer is aligned so that we can indirect through a
- * long *, and stuff this pointer in xdrs->x_buf. Doing
- * a fread or fwrite to a scratch buffer would defeat
- * most of the gains to be had here and require storage
- * management on this buffer, so we don't do this.
- */
- return NULL;
-}
-
-static bool_t
-xdrstdio_getint32 (XDR *xdrs, int32_t *ip)
-{
- int32_t mycopy;
-
- if (fread ((caddr_t) &mycopy, 4, 1, (FILE *) xdrs->x_private) != 1)
- return FALSE;
- *ip = ntohl (mycopy);
- return TRUE;
-}
-
-static bool_t
-xdrstdio_putint32 (XDR *xdrs, const int32_t *ip)
-{
- int32_t mycopy = htonl (*ip);
-
- ip = &mycopy;
- if (fwrite ((caddr_t) ip, 4, 1, (FILE *) xdrs->x_private) != 1)
- return FALSE;
- return TRUE;
-}
-
-/* libc_hidden_def (xdrstdio_create) */
+++ /dev/null
-/*_________________________________________________________________
- |
- | xdrf.h - include file for C routines that want to use the
- | functions below.
-*/
-
-int xdropen(XDR *xdrs, const char *filename, const char *type);
-int xdrclose(XDR *xdrs) ;
-int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) ;
-
+++ /dev/null
-# This make file is part of the xdrf package.
-#
-# (C) 1995 Frans van Hoesel, hoesel@chem.rug.nl
-#
-# 2006 modified by Cezary Czaplewski
-
-# Set C compiler and flags for ARCH
-CC = cc
-CFLAGS = -O
-
-M4 = m4
-M4FILE = underscore.m4
-
-libxdrf.a: libxdrf.o ftocstr.o
- ar cr libxdrf.a $?
-
-clean:
- rm -f libxdrf.o ftocstr.o libxdrf.a
-
-ftocstr.o: ftocstr.c
- $(CC) $(CFLAGS) -c ftocstr.c
-
-libxdrf.o: libxdrf.m4 $(M4FILE)
- $(M4) $(M4FILE) libxdrf.m4 > libxdrf.c
- $(CC) $(CFLAGS) -c libxdrf.c
- rm -f libxdrf.c
-
+++ /dev/null
-# This make file is part of the xdrf package.
-#
-# (C) 1995 Frans van Hoesel, hoesel@chem.rug.nl
-#
-# 2006 modified by Cezary Czaplewski
-
-# Set C compiler and flags for ARCH
-CC = cc
-CFLAGS = -O
-
-M4 = m4
-M4FILE = underscore.m4
-
-libxdrf.a: libxdrf.o ftocstr.o
- ar cr libxdrf.a $?
-
-clean:
- rm -f libxdrfo ftocstr.o libxdrf.a
-
-ftocstr.o: ftocstr.c
- $(CC) $(CFLAGS) -c ftocstr.c
-
-libxdrf.o: libxdrf.m4 $(M4FILE)
- $(M4) $(M4FILE) libxdrf.m4 > libxdrf.c
- $(CC) $(CFLAGS) -c libxdrf.c
- rm -f libxdrf.c
-
+++ /dev/null
-
-
-int ftocstr(ds, dl, ss, sl)
- char *ds, *ss; /* dst, src ptrs */
- int dl; /* dst max len */
- int sl; /* src len */
-{
- char *p;
-
- for (p = ss + sl; --p >= ss && *p == ' '; ) ;
- sl = p - ss + 1;
- dl--;
- ds[0] = 0;
- if (sl > dl)
- return 1;
- while (sl--)
- (*ds++ = *ss++);
- *ds = '\0';
- return 0;
-}
-
-
-int ctofstr(ds, dl, ss)
- char *ds; /* dest space */
- int dl; /* max dest length */
- char *ss; /* src string (0-term) */
-{
- while (dl && *ss) {
- *ds++ = *ss++;
- dl--;
- }
- while (dl--)
- *ds++ = ' ';
- return 0;
-}
+++ /dev/null
-/*____________________________________________________________________________
- |
- | libxdrf - portable fortran interface to xdr. some xdr routines
- | are C routines for compressed coordinates
- |
- | version 1.1
- |
- | This collection of routines is intended to write and read
- | data in a portable way to a file, so data written on one type
- | of machine can be read back on a different type.
- |
- | all fortran routines use an integer 'xdrid', which is an id to the
- | current xdr file, and is set by xdrfopen.
- | most routines have in integer 'ret' which is the return value.
- | The value of 'ret' is zero on failure, and most of the time one
- | on succes.
- |
- | There are three routines useful for C users:
- | xdropen(), xdrclose(), xdr3dfcoord().
- | The first two replace xdrstdio_create and xdr_destroy, and *must* be
- | used when you plan to use xdr3dfcoord(). (they are also a bit
- | easier to interface). For writing data other than compressed coordinates
- | you should use the standard C xdr routines (see xdr man page)
- |
- | xdrfopen(xdrid, filename, mode, ret)
- | character *(*) filename
- | character *(*) mode
- |
- | this will open the file with the given filename (string)
- | and the given mode, it returns an id in xdrid, which is
- | to be used in all other calls to xdrf routines.
- | mode is 'w' to create, or update an file, for all other
- | values of mode the file is opened for reading
- |
- | you need to call xdrfclose to flush the output and close
- | the file.
- | Note that you should not use xdrstdio_create, which comes with the
- | standard xdr library
- |
- | xdrfclose(xdrid, ret)
- | flush the data to the file, and closes the file;
- | You should not use xdr_destroy (which comes standard with
- | the xdr libraries.
- |
- | xdrfbool(xdrid, bp, ret)
- | integer pb
- |
- | This filter produces values of either 1 or 0
- |
- | xdrfchar(xdrid, cp, ret)
- | character cp
- |
- | filter that translate between characters and their xdr representation
- | Note that the characters in not compressed and occupies 4 bytes.
- |
- | xdrfdouble(xdrid, dp, ret)
- | double dp
- |
- | read/write a double.
- |
- | xdrffloat(xdrid, fp, ret)
- | float fp
- |
- | read/write a float.
- |
- | xdrfint(xdrid, ip, ret)
- | integer ip
- |
- | read/write integer.
- |
- | xdrflong(xdrid, lp, ret)
- | integer lp
- |
- | this routine has a possible portablility problem due to 64 bits longs.
- |
- | xdrfshort(xdrid, sp, ret)
- | integer *2 sp
- |
- | xdrfstring(xdrid, sp, maxsize, ret)
- | character *(*)
- | integer maxsize
- |
- | read/write a string, with maximum length given by maxsize
- |
- | xdrfwrapstring(xdris, sp, ret)
- | character *(*)
- |
- | read/write a string (it is the same as xdrfstring accept that it finds
- | the stringlength itself.
- |
- | xdrfvector(xdrid, cp, size, xdrfproc, ret)
- | character *(*)
- | integer size
- | external xdrfproc
- |
- | read/write an array pointed to by cp, with number of elements
- | defined by 'size'. the routine 'xdrfproc' is the name
- | of one of the above routines to read/write data (like xdrfdouble)
- | In contrast with the c-version you don't need to specify the
- | byte size of an element.
- | xdrfstring is not allowed here (it is in the c version)
- |
- | xdrf3dfcoord(xdrid, fp, size, precision, ret)
- | real (*) fp
- | real precision
- | integer size
- |
- | this is *NOT* a standard xdr routine. I named it this way, because
- | it invites people to use the other xdr routines.
- | It is introduced to store specifically 3d coordinates of molecules
- | (as found in molecular dynamics) and it writes it in a compressed way.
- | It starts by multiplying all numbers by precision and
- | rounding the result to integer. effectively converting
- | all floating point numbers to fixed point.
- | it uses an algorithm for compression that is optimized for
- | molecular data, but could be used for other 3d coordinates
- | as well. There is subtantial overhead involved, so call this
- | routine only if you have a large number of coordinates to read/write
- |
- | ________________________________________________________________________
- |
- | Below are the routines to be used by C programmers. Use the 'normal'
- | xdr routines to write integers, floats, etc (see man xdr)
- |
- | int xdropen(XDR *xdrs, const char *filename, const char *type)
- | This will open the file with the given filename and the
- | given mode. You should pass it an allocated XDR struct
- | in xdrs, to be used in all other calls to xdr routines.
- | Mode is 'w' to create, or update an file, and for all
- | other values of mode the file is opened for reading.
- | You need to call xdrclose to flush the output and close
- | the file.
- |
- | Note that you should not use xdrstdio_create, which
- | comes with the standard xdr library.
- |
- | int xdrclose(XDR *xdrs)
- | Flush the data to the file, and close the file;
- | You should not use xdr_destroy (which comes standard
- | with the xdr libraries).
- |
- | int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision)
- | This is \fInot\fR a standard xdr routine. I named it this
- | way, because it invites people to use the other xdr
- | routines.
- |
- | (c) 1995 Frans van Hoesel, hoesel@chem.rug.nl
-*/
-
-
-#include <limits.h>
-#include <malloc.h>
-#include <math.h>
-#include <rpc/rpc.h>
-#include <rpc/xdr.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include "xdrf.h"
-
-int ftocstr(char *, int, char *, int);
-int ctofstr(char *, int, char *);
-
-#define MAXID 20
-static FILE *xdrfiles[MAXID];
-static XDR *xdridptr[MAXID];
-static char xdrmodes[MAXID];
-static unsigned int cnt;
-
-typedef void (* FUNCTION(xdrfproc)) (int *, void *, int *);
-
-void
-FUNCTION(xdrfbool) ARGS(`xdrid, pb, ret')
-int *xdrid, *ret;
-int *pb;
-{
- *ret = xdr_bool(xdridptr[*xdrid], (bool_t *) pb);
- cnt += sizeof(int);
-}
-
-void
-FUNCTION(xdrfchar) ARGS(`xdrid, cp, ret')
-int *xdrid, *ret;
-char *cp;
-{
- *ret = xdr_char(xdridptr[*xdrid], cp);
- cnt += sizeof(char);
-}
-
-void
-FUNCTION(xdrfdouble) ARGS(`xdrid, dp, ret')
-int *xdrid, *ret;
-double *dp;
-{
- *ret = xdr_double(xdridptr[*xdrid], dp);
- cnt += sizeof(double);
-}
-
-void
-FUNCTION(xdrffloat) ARGS(`xdrid, fp, ret')
-int *xdrid, *ret;
-float *fp;
-{
- *ret = xdr_float(xdridptr[*xdrid], fp);
- cnt += sizeof(float);
-}
-
-void
-FUNCTION(xdrfint) ARGS(`xdrid, ip, ret')
-int *xdrid, *ret;
-int *ip;
-{
- *ret = xdr_int(xdridptr[*xdrid], ip);
- cnt += sizeof(int);
-}
-
-void
-FUNCTION(xdrflong) ARGS(`xdrid, lp, ret')
-int *xdrid, *ret;
-long *lp;
-{
- *ret = xdr_long(xdridptr[*xdrid], lp);
- cnt += sizeof(long);
-}
-
-void
-FUNCTION(xdrfshort) ARGS(`xdrid, sp, ret')
-int *xdrid, *ret;
-short *sp;
-{
- *ret = xdr_short(xdridptr[*xdrid], sp);
- cnt += sizeof(sp);
-}
-
-void
-FUNCTION(xdrfuchar) ARGS(`xdrid, ucp, ret')
-int *xdrid, *ret;
-char *ucp;
-{
- *ret = xdr_u_char(xdridptr[*xdrid], ucp);
- cnt += sizeof(char);
-}
-
-void
-FUNCTION(xdrfulong) ARGS(`xdrid, ulp, ret')
-int *xdrid, *ret;
-unsigned long *ulp;
-{
- *ret = xdr_u_long(xdridptr[*xdrid], ulp);
- cnt += sizeof(unsigned long);
-}
-
-void
-FUNCTION(xdrfushort) ARGS(`xdrid, usp, ret')
-int *xdrid, *ret;
-unsigned short *usp;
-{
- *ret = xdr_u_short(xdridptr[*xdrid], usp);
- cnt += sizeof(unsigned short);
-}
-
-void
-FUNCTION(xdrf3dfcoord) ARGS(`xdrid, fp, size, precision, ret')
-int *xdrid, *ret;
-float *fp;
-int *size;
-float *precision;
-{
- *ret = xdr3dfcoord(xdridptr[*xdrid], fp, size, precision);
-}
-
-void
-FUNCTION(xdrfstring) ARGS(`xdrid, STRING_ARG(sp), maxsize, ret')
-int *xdrid, *ret;
-STRING_ARG_DECL(sp);
-int *maxsize;
-{
- char *tsp;
-
- tsp = (char*) malloc(((STRING_LEN(sp)) + 1) * sizeof(char));
- if (tsp == NULL) {
- *ret = -1;
- return;
- }
- if (ftocstr(tsp, *maxsize+1, STRING_PTR(sp), STRING_LEN(sp))) {
- *ret = -1;
- free(tsp);
- return;
- }
- *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int) *maxsize);
- ctofstr( STRING_PTR(sp), STRING_LEN(sp), tsp);
- cnt += *maxsize;
- free(tsp);
-}
-
-void
-FUNCTION(xdrfwrapstring) ARGS(`xdrid, STRING_ARG(sp), ret')
-int *xdrid, *ret;
-STRING_ARG_DECL(sp);
-{
- char *tsp;
- int maxsize;
- maxsize = (STRING_LEN(sp)) + 1;
- tsp = (char*) malloc(maxsize * sizeof(char));
- if (tsp == NULL) {
- *ret = -1;
- return;
- }
- if (ftocstr(tsp, maxsize, STRING_PTR(sp), STRING_LEN(sp))) {
- *ret = -1;
- free(tsp);
- return;
- }
- *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int)maxsize);
- ctofstr( STRING_PTR(sp), STRING_LEN(sp), tsp);
- cnt += maxsize;
- free(tsp);
-}
-
-void
-FUNCTION(xdrfopaque) ARGS(`xdrid, cp, ccnt, ret')
-int *xdrid, *ret;
-caddr_t *cp;
-int *ccnt;
-{
- *ret = xdr_opaque(xdridptr[*xdrid], (caddr_t)*cp, (u_int)*ccnt);
- cnt += *ccnt;
-}
-
-void
-FUNCTION(xdrfsetpos) ARGS(`xdrid, pos, ret')
-int *xdrid, *ret;
-int *pos;
-{
- *ret = xdr_setpos(xdridptr[*xdrid], (u_int) *pos);
-}
-
-void
-FUNCTION(xdrf) ARGS(`xdrid, pos')
-int *xdrid, *pos;
-{
- *pos = xdr_getpos(xdridptr[*xdrid]);
-}
-
-void
-FUNCTION(xdrfvector) ARGS(`xdrid, cp, size, elproc, ret')
-int *xdrid, *ret;
-char *cp;
-int *size;
-FUNCTION(xdrfproc) elproc;
-{
- int lcnt;
- cnt = 0;
- for (lcnt = 0; lcnt < *size; lcnt++) {
- elproc(xdrid, (cp+cnt) , ret);
- }
-}
-
-
-void
-FUNCTION(xdrfclose) ARGS(`xdrid, ret')
-int *xdrid;
-int *ret;
-{
- *ret = xdrclose(xdridptr[*xdrid]);
- cnt = 0;
-}
-
-void
-FUNCTION(xdrfopen) ARGS(`xdrid, STRING_ARG(fp), STRING_ARG(mode), ret')
-int *xdrid;
-STRING_ARG_DECL(fp);
-STRING_ARG_DECL(mode);
-int *ret;
-{
- char fname[512];
- char fmode[3];
-
- if (ftocstr(fname, sizeof(fname), STRING_PTR(fp), STRING_LEN(fp))) {
- *ret = 0;
- }
- if (ftocstr(fmode, sizeof(fmode), STRING_PTR(mode),
- STRING_LEN(mode))) {
- *ret = 0;
- }
-
- *xdrid = xdropen(NULL, fname, fmode);
- if (*xdrid == 0)
- *ret = 0;
- else
- *ret = 1;
-}
-
-/*___________________________________________________________________________
- |
- | what follows are the C routines for opening, closing xdr streams
- | and the routine to read/write compressed coordinates together
- | with some routines to assist in this task (those are marked
- | static and cannot be called from user programs)
-*/
-#define MAXABS INT_MAX-2
-
-#ifndef MIN
-#define MIN(x,y) ((x) < (y) ? (x):(y))
-#endif
-#ifndef MAX
-#define MAX(x,y) ((x) > (y) ? (x):(y))
-#endif
-#ifndef SQR
-#define SQR(x) ((x)*(x))
-#endif
-static int magicints[] = {
- 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 8, 10, 12, 16, 20, 25, 32, 40, 50, 64,
- 80, 101, 128, 161, 203, 256, 322, 406, 512, 645,
- 812, 1024, 1290, 1625, 2048, 2580, 3250, 4096, 5060, 6501,
- 8192, 10321, 13003, 16384, 20642, 26007, 32768, 41285, 52015, 65536,
- 82570, 104031, 131072, 165140, 208063, 262144, 330280, 416127, 524287, 660561,
- 832255, 1048576, 1321122, 1664510, 2097152, 2642245, 3329021, 4194304, 5284491, 6658042,
- 8388607, 10568983, 13316085, 16777216 };
-
-#define FIRSTIDX 9
-/* note that magicints[FIRSTIDX-1] == 0 */
-#define LASTIDX (sizeof(magicints) / sizeof(*magicints))
-
-
-/*__________________________________________________________________________
- |
- | xdropen - open xdr file
- |
- | This versions differs from xdrstdio_create, because I need to know
- | the state of the file (read or write) so I can use xdr3dfcoord
- | in eigther read or write mode, and the file descriptor
- | so I can close the file (something xdr_destroy doesn't do).
- |
-*/
-
-int xdropen(XDR *xdrs, const char *filename, const char *type) {
- static int init_done = 0;
- enum xdr_op lmode;
- const char *type1;
- int xdrid;
-
- if (init_done == 0) {
- for (xdrid = 1; xdrid < MAXID; xdrid++) {
- xdridptr[xdrid] = NULL;
- }
- init_done = 1;
- }
- xdrid = 1;
- while (xdrid < MAXID && xdridptr[xdrid] != NULL) {
- xdrid++;
- }
- if (xdrid == MAXID) {
- return 0;
- }
- if (*type == 'w' || *type == 'W') {
- type = "w+";
- type1 = "a+";
- lmode = XDR_ENCODE;
- } else {
- type = "r";
- type1 = "r";
- lmode = XDR_DECODE;
- }
- xdrfiles[xdrid] = fopen(filename, type1);
- if (xdrfiles[xdrid] == NULL) {
- xdrs = NULL;
- return 0;
- }
- xdrmodes[xdrid] = *type;
- /* next test isn't usefull in the case of C language
- * but is used for the Fortran interface
- * (C users are expected to pass the address of an already allocated
- * XDR staructure)
- */
- if (xdrs == NULL) {
- xdridptr[xdrid] = (XDR *) malloc(sizeof(XDR));
- xdrstdio_create(xdridptr[xdrid], xdrfiles[xdrid], lmode);
- } else {
- xdridptr[xdrid] = xdrs;
- xdrstdio_create(xdrs, xdrfiles[xdrid], lmode);
- }
- return xdrid;
-}
-
-/*_________________________________________________________________________
- |
- | xdrclose - close a xdr file
- |
- | This will flush the xdr buffers, and destroy the xdr stream.
- | It also closes the associated file descriptor (this is *not*
- | done by xdr_destroy).
- |
-*/
-
-int xdrclose(XDR *xdrs) {
- int xdrid;
-
- if (xdrs == NULL) {
- fprintf(stderr, "xdrclose: passed a NULL pointer\n");
- exit(1);
- }
- for (xdrid = 1; xdrid < MAXID; xdrid++) {
- if (xdridptr[xdrid] == xdrs) {
-
- xdr_destroy(xdrs);
- fclose(xdrfiles[xdrid]);
- xdridptr[xdrid] = NULL;
- return 1;
- }
- }
- fprintf(stderr, "xdrclose: no such open xdr file\n");
- exit(1);
-
-}
-
-/*____________________________________________________________________________
- |
- | sendbits - encode num into buf using the specified number of bits
- |
- | This routines appends the value of num to the bits already present in
- | the array buf. You need to give it the number of bits to use and you
- | better make sure that this number of bits is enough to hold the value
- | Also num must be positive.
- |
-*/
-
-static void sendbits(int buf[], int num_of_bits, int num) {
-
- unsigned int cnt, lastbyte;
- int lastbits;
- unsigned char * cbuf;
-
- cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf);
- cnt = (unsigned int) buf[0];
- lastbits = buf[1];
- lastbyte =(unsigned int) buf[2];
- while (num_of_bits >= 8) {
- lastbyte = (lastbyte << 8) | ((num >> (num_of_bits -8)) /* & 0xff*/);
- cbuf[cnt++] = lastbyte >> lastbits;
- num_of_bits -= 8;
- }
- if (num_of_bits > 0) {
- lastbyte = (lastbyte << num_of_bits) | num;
- lastbits += num_of_bits;
- if (lastbits >= 8) {
- lastbits -= 8;
- cbuf[cnt++] = lastbyte >> lastbits;
- }
- }
- buf[0] = cnt;
- buf[1] = lastbits;
- buf[2] = lastbyte;
- if (lastbits>0) {
- cbuf[cnt] = lastbyte << (8 - lastbits);
- }
-}
-
-/*_________________________________________________________________________
- |
- | sizeofint - calculate bitsize of an integer
- |
- | return the number of bits needed to store an integer with given max size
- |
-*/
-
-static int sizeofint(const int size) {
- unsigned int num = 1;
- int num_of_bits = 0;
-
- while (size >= num && num_of_bits < 32) {
- num_of_bits++;
- num <<= 1;
- }
- return num_of_bits;
-}
-
-/*___________________________________________________________________________
- |
- | sizeofints - calculate 'bitsize' of compressed ints
- |
- | given the number of small unsigned integers and the maximum value
- | return the number of bits needed to read or write them with the
- | routines receiveints and sendints. You need this parameter when
- | calling these routines. Note that for many calls I can use
- | the variable 'smallidx' which is exactly the number of bits, and
- | So I don't need to call 'sizeofints for those calls.
-*/
-
-static int sizeofints( const int num_of_ints, unsigned int sizes[]) {
- int i, num;
- unsigned int num_of_bytes, num_of_bits, bytes[32], bytecnt, tmp;
- num_of_bytes = 1;
- bytes[0] = 1;
- num_of_bits = 0;
- for (i=0; i < num_of_ints; i++) {
- tmp = 0;
- for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) {
- tmp = bytes[bytecnt] * sizes[i] + tmp;
- bytes[bytecnt] = tmp & 0xff;
- tmp >>= 8;
- }
- while (tmp != 0) {
- bytes[bytecnt++] = tmp & 0xff;
- tmp >>= 8;
- }
- num_of_bytes = bytecnt;
- }
- num = 1;
- num_of_bytes--;
- while (bytes[num_of_bytes] >= num) {
- num_of_bits++;
- num *= 2;
- }
- return num_of_bits + num_of_bytes * 8;
-
-}
-
-/*____________________________________________________________________________
- |
- | sendints - send a small set of small integers in compressed format
- |
- | this routine is used internally by xdr3dfcoord, to send a set of
- | small integers to the buffer.
- | Multiplication with fixed (specified maximum ) sizes is used to get
- | to one big, multibyte integer. Allthough the routine could be
- | modified to handle sizes bigger than 16777216, or more than just
- | a few integers, this is not done, because the gain in compression
- | isn't worth the effort. Note that overflowing the multiplication
- | or the byte buffer (32 bytes) is unchecked and causes bad results.
- |
- */
-
-static void sendints(int buf[], const int num_of_ints, const int num_of_bits,
- unsigned int sizes[], unsigned int nums[]) {
-
- int i;
- unsigned int bytes[32], num_of_bytes, bytecnt, tmp;
-
- tmp = nums[0];
- num_of_bytes = 0;
- do {
- bytes[num_of_bytes++] = tmp & 0xff;
- tmp >>= 8;
- } while (tmp != 0);
-
- for (i = 1; i < num_of_ints; i++) {
- if (nums[i] >= sizes[i]) {
- fprintf(stderr,"major breakdown in sendints num %d doesn't "
- "match size %d\n", nums[i], sizes[i]);
- exit(1);
- }
- /* use one step multiply */
- tmp = nums[i];
- for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) {
- tmp = bytes[bytecnt] * sizes[i] + tmp;
- bytes[bytecnt] = tmp & 0xff;
- tmp >>= 8;
- }
- while (tmp != 0) {
- bytes[bytecnt++] = tmp & 0xff;
- tmp >>= 8;
- }
- num_of_bytes = bytecnt;
- }
- if (num_of_bits >= num_of_bytes * 8) {
- for (i = 0; i < num_of_bytes; i++) {
- sendbits(buf, 8, bytes[i]);
- }
- sendbits(buf, num_of_bits - num_of_bytes * 8, 0);
- } else {
- for (i = 0; i < num_of_bytes-1; i++) {
- sendbits(buf, 8, bytes[i]);
- }
- sendbits(buf, num_of_bits- (num_of_bytes -1) * 8, bytes[i]);
- }
-}
-
-
-/*___________________________________________________________________________
- |
- | receivebits - decode number from buf using specified number of bits
- |
- | extract the number of bits from the array buf and construct an integer
- | from it. Return that value.
- |
-*/
-
-static int receivebits(int buf[], int num_of_bits) {
-
- int cnt, num;
- unsigned int lastbits, lastbyte;
- unsigned char * cbuf;
- int mask = (1 << num_of_bits) -1;
-
- cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf);
- cnt = buf[0];
- lastbits = (unsigned int) buf[1];
- lastbyte = (unsigned int) buf[2];
-
- num = 0;
- while (num_of_bits >= 8) {
- lastbyte = ( lastbyte << 8 ) | cbuf[cnt++];
- num |= (lastbyte >> lastbits) << (num_of_bits - 8);
- num_of_bits -=8;
- }
- if (num_of_bits > 0) {
- if (lastbits < num_of_bits) {
- lastbits += 8;
- lastbyte = (lastbyte << 8) | cbuf[cnt++];
- }
- lastbits -= num_of_bits;
- num |= (lastbyte >> lastbits) & ((1 << num_of_bits) -1);
- }
- num &= mask;
- buf[0] = cnt;
- buf[1] = lastbits;
- buf[2] = lastbyte;
- return num;
-}
-
-/*____________________________________________________________________________
- |
- | receiveints - decode 'small' integers from the buf array
- |
- | this routine is the inverse from sendints() and decodes the small integers
- | written to buf by calculating the remainder and doing divisions with
- | the given sizes[]. You need to specify the total number of bits to be
- | used from buf in num_of_bits.
- |
-*/
-
-static void receiveints(int buf[], const int num_of_ints, int num_of_bits,
- unsigned int sizes[], int nums[]) {
- int bytes[32];
- int i, j, num_of_bytes, p, num;
-
- bytes[1] = bytes[2] = bytes[3] = 0;
- num_of_bytes = 0;
- while (num_of_bits > 8) {
- bytes[num_of_bytes++] = receivebits(buf, 8);
- num_of_bits -= 8;
- }
- if (num_of_bits > 0) {
- bytes[num_of_bytes++] = receivebits(buf, num_of_bits);
- }
- for (i = num_of_ints-1; i > 0; i--) {
- num = 0;
- for (j = num_of_bytes-1; j >=0; j--) {
- num = (num << 8) | bytes[j];
- p = num / sizes[i];
- bytes[j] = p;
- num = num - p * sizes[i];
- }
- nums[i] = num;
- }
- nums[0] = bytes[0] | (bytes[1] << 8) | (bytes[2] << 16) | (bytes[3] << 24);
-}
-
-/*____________________________________________________________________________
- |
- | xdr3dfcoord - read or write compressed 3d coordinates to xdr file.
- |
- | this routine reads or writes (depending on how you opened the file with
- | xdropen() ) a large number of 3d coordinates (stored in *fp).
- | The number of coordinates triplets to write is given by *size. On
- | read this number may be zero, in which case it reads as many as were written
- | or it may specify the number if triplets to read (which should match the
- | number written).
- | Compression is achieved by first converting all floating numbers to integer
- | using multiplication by *precision and rounding to the nearest integer.
- | Then the minimum and maximum value are calculated to determine the range.
- | The limited range of integers so found, is used to compress the coordinates.
- | In addition the differences between succesive coordinates is calculated.
- | If the difference happens to be 'small' then only the difference is saved,
- | compressing the data even more. The notion of 'small' is changed dynamically
- | and is enlarged or reduced whenever needed or possible.
- | Extra compression is achieved in the case of GROMOS and coordinates of
- | water molecules. GROMOS first writes out the Oxygen position, followed by
- | the two hydrogens. In order to make the differences smaller (and thereby
- | compression the data better) the order is changed into first one hydrogen
- | then the oxygen, followed by the other hydrogen. This is rather special, but
- | it shouldn't harm in the general case.
- |
- */
-
-int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) {
-
-
- static int *ip = NULL;
- static int oldsize;
- static int *buf;
-
- int minint[3], maxint[3], mindiff, *lip, diff;
- int lint1, lint2, lint3, oldlint1, oldlint2, oldlint3, smallidx;
- int minidx, maxidx;
- unsigned sizeint[3], sizesmall[3], bitsizeint[3], size3, *luip;
- int flag, k;
- int small, smaller, larger, i, is_small, is_smaller, run, prevrun;
- float *lfp, lf;
- int tmp, *thiscoord, prevcoord[3];
- unsigned int tmpcoord[30];
-
- int bufsize, xdrid, lsize;
- unsigned int bitsize;
- float inv_precision;
- int errval = 1;
-
- /* find out if xdrs is opened for reading or for writing */
- xdrid = 0;
- while (xdridptr[xdrid] != xdrs) {
- xdrid++;
- if (xdrid >= MAXID) {
- fprintf(stderr, "xdr error. no open xdr stream\n");
- exit (1);
- }
- }
- if (xdrmodes[xdrid] == 'w') {
-
- /* xdrs is open for writing */
-
- if (xdr_int(xdrs, size) == 0)
- return 0;
- size3 = *size * 3;
- /* when the number of coordinates is small, don't try to compress; just
- * write them as floats using xdr_vector
- */
- if (*size <= 9 ) {
- return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp),
- (xdrproc_t)xdr_float));
- }
-
- xdr_float(xdrs, precision);
- if (ip == NULL) {
- ip = (int *)malloc(size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)malloc(bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- } else if (*size > oldsize) {
- ip = (int *)realloc(ip, size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)realloc(buf, bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- }
- /* buf[0-2] are special and do not contain actual data */
- buf[0] = buf[1] = buf[2] = 0;
- minint[0] = minint[1] = minint[2] = INT_MAX;
- maxint[0] = maxint[1] = maxint[2] = INT_MIN;
- prevrun = -1;
- lfp = fp;
- lip = ip;
- mindiff = INT_MAX;
- oldlint1 = oldlint2 = oldlint3 = 0;
- while(lfp < fp + size3 ) {
- /* find nearest integer */
- if (*lfp >= 0.0)
- lf = *lfp * *precision + 0.5;
- else
- lf = *lfp * *precision - 0.5;
- if (fabs(lf) > MAXABS) {
- /* scaling would cause overflow */
- errval = 0;
- }
- lint1 = lf;
- if (lint1 < minint[0]) minint[0] = lint1;
- if (lint1 > maxint[0]) maxint[0] = lint1;
- *lip++ = lint1;
- lfp++;
- if (*lfp >= 0.0)
- lf = *lfp * *precision + 0.5;
- else
- lf = *lfp * *precision - 0.5;
- if (fabs(lf) > MAXABS) {
- /* scaling would cause overflow */
- errval = 0;
- }
- lint2 = lf;
- if (lint2 < minint[1]) minint[1] = lint2;
- if (lint2 > maxint[1]) maxint[1] = lint2;
- *lip++ = lint2;
- lfp++;
- if (*lfp >= 0.0)
- lf = *lfp * *precision + 0.5;
- else
- lf = *lfp * *precision - 0.5;
- if (fabs(lf) > MAXABS) {
- /* scaling would cause overflow */
- errval = 0;
- }
- lint3 = lf;
- if (lint3 < minint[2]) minint[2] = lint3;
- if (lint3 > maxint[2]) maxint[2] = lint3;
- *lip++ = lint3;
- lfp++;
- diff = abs(oldlint1-lint1)+abs(oldlint2-lint2)+abs(oldlint3-lint3);
- if (diff < mindiff && lfp > fp + 3)
- mindiff = diff;
- oldlint1 = lint1;
- oldlint2 = lint2;
- oldlint3 = lint3;
- }
- xdr_int(xdrs, &(minint[0]));
- xdr_int(xdrs, &(minint[1]));
- xdr_int(xdrs, &(minint[2]));
-
- xdr_int(xdrs, &(maxint[0]));
- xdr_int(xdrs, &(maxint[1]));
- xdr_int(xdrs, &(maxint[2]));
-
- if ((float)maxint[0] - (float)minint[0] >= MAXABS ||
- (float)maxint[1] - (float)minint[1] >= MAXABS ||
- (float)maxint[2] - (float)minint[2] >= MAXABS) {
- /* turning value in unsigned by subtracting minint
- * would cause overflow
- */
- errval = 0;
- }
- sizeint[0] = maxint[0] - minint[0]+1;
- sizeint[1] = maxint[1] - minint[1]+1;
- sizeint[2] = maxint[2] - minint[2]+1;
-
- /* check if one of the sizes is to big to be multiplied */
- if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) {
- bitsizeint[0] = sizeofint(sizeint[0]);
- bitsizeint[1] = sizeofint(sizeint[1]);
- bitsizeint[2] = sizeofint(sizeint[2]);
- bitsize = 0; /* flag the use of large sizes */
- } else {
- bitsize = sizeofints(3, sizeint);
- }
- lip = ip;
- luip = (unsigned int *) ip;
- smallidx = FIRSTIDX;
- while (smallidx < LASTIDX && magicints[smallidx] < mindiff) {
- smallidx++;
- }
- xdr_int(xdrs, &smallidx);
- maxidx = MIN(LASTIDX, smallidx + 8) ;
- minidx = maxidx - 8; /* often this equal smallidx */
- smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2;
- small = magicints[smallidx] / 2;
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx];
- larger = magicints[maxidx] / 2;
- i = 0;
- while (i < *size) {
- is_small = 0;
- thiscoord = (int *)(luip) + i * 3;
- if (smallidx < maxidx && i >= 1 &&
- abs(thiscoord[0] - prevcoord[0]) < larger &&
- abs(thiscoord[1] - prevcoord[1]) < larger &&
- abs(thiscoord[2] - prevcoord[2]) < larger) {
- is_smaller = 1;
- } else if (smallidx > minidx) {
- is_smaller = -1;
- } else {
- is_smaller = 0;
- }
- if (i + 1 < *size) {
- if (abs(thiscoord[0] - thiscoord[3]) < small &&
- abs(thiscoord[1] - thiscoord[4]) < small &&
- abs(thiscoord[2] - thiscoord[5]) < small) {
- /* interchange first with second atom for better
- * compression of water molecules
- */
- tmp = thiscoord[0]; thiscoord[0] = thiscoord[3];
- thiscoord[3] = tmp;
- tmp = thiscoord[1]; thiscoord[1] = thiscoord[4];
- thiscoord[4] = tmp;
- tmp = thiscoord[2]; thiscoord[2] = thiscoord[5];
- thiscoord[5] = tmp;
- is_small = 1;
- }
-
- }
- tmpcoord[0] = thiscoord[0] - minint[0];
- tmpcoord[1] = thiscoord[1] - minint[1];
- tmpcoord[2] = thiscoord[2] - minint[2];
- if (bitsize == 0) {
- sendbits(buf, bitsizeint[0], tmpcoord[0]);
- sendbits(buf, bitsizeint[1], tmpcoord[1]);
- sendbits(buf, bitsizeint[2], tmpcoord[2]);
- } else {
- sendints(buf, 3, bitsize, sizeint, tmpcoord);
- }
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
- thiscoord = thiscoord + 3;
- i++;
-
- run = 0;
- if (is_small == 0 && is_smaller == -1)
- is_smaller = 0;
- while (is_small && run < 8*3) {
- if (is_smaller == -1 && (
- SQR(thiscoord[0] - prevcoord[0]) +
- SQR(thiscoord[1] - prevcoord[1]) +
- SQR(thiscoord[2] - prevcoord[2]) >= smaller * smaller)) {
- is_smaller = 0;
- }
-
- tmpcoord[run++] = thiscoord[0] - prevcoord[0] + small;
- tmpcoord[run++] = thiscoord[1] - prevcoord[1] + small;
- tmpcoord[run++] = thiscoord[2] - prevcoord[2] + small;
-
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
-
- i++;
- thiscoord = thiscoord + 3;
- is_small = 0;
- if (i < *size &&
- abs(thiscoord[0] - prevcoord[0]) < small &&
- abs(thiscoord[1] - prevcoord[1]) < small &&
- abs(thiscoord[2] - prevcoord[2]) < small) {
- is_small = 1;
- }
- }
- if (run != prevrun || is_smaller != 0) {
- prevrun = run;
- sendbits(buf, 1, 1); /* flag the change in run-length */
- sendbits(buf, 5, run+is_smaller+1);
- } else {
- sendbits(buf, 1, 0); /* flag the fact that runlength did not change */
- }
- for (k=0; k < run; k+=3) {
- sendints(buf, 3, smallidx, sizesmall, &tmpcoord[k]);
- }
- if (is_smaller != 0) {
- smallidx += is_smaller;
- if (is_smaller < 0) {
- small = smaller;
- smaller = magicints[smallidx-1] / 2;
- } else {
- smaller = small;
- small = magicints[smallidx] / 2;
- }
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx];
- }
- }
- if (buf[1] != 0) buf[0]++;;
- xdr_int(xdrs, &(buf[0])); /* buf[0] holds the length in bytes */
- return errval * (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0]));
- } else {
-
- /* xdrs is open for reading */
-
- if (xdr_int(xdrs, &lsize) == 0)
- return 0;
- if (*size != 0 && lsize != *size) {
- fprintf(stderr, "wrong number of coordinates in xdr3dfcoor; "
- "%d arg vs %d in file", *size, lsize);
- }
- *size = lsize;
- size3 = *size * 3;
- if (*size <= 9) {
- return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp),
- (xdrproc_t)xdr_float));
- }
- xdr_float(xdrs, precision);
- if (ip == NULL) {
- ip = (int *)malloc(size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)malloc(bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- } else if (*size > oldsize) {
- ip = (int *)realloc(ip, size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)realloc(buf, bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- }
- buf[0] = buf[1] = buf[2] = 0;
-
- xdr_int(xdrs, &(minint[0]));
- xdr_int(xdrs, &(minint[1]));
- xdr_int(xdrs, &(minint[2]));
-
- xdr_int(xdrs, &(maxint[0]));
- xdr_int(xdrs, &(maxint[1]));
- xdr_int(xdrs, &(maxint[2]));
-
- sizeint[0] = maxint[0] - minint[0]+1;
- sizeint[1] = maxint[1] - minint[1]+1;
- sizeint[2] = maxint[2] - minint[2]+1;
-
- /* check if one of the sizes is to big to be multiplied */
- if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) {
- bitsizeint[0] = sizeofint(sizeint[0]);
- bitsizeint[1] = sizeofint(sizeint[1]);
- bitsizeint[2] = sizeofint(sizeint[2]);
- bitsize = 0; /* flag the use of large sizes */
- } else {
- bitsize = sizeofints(3, sizeint);
- }
-
- xdr_int(xdrs, &smallidx);
- maxidx = MIN(LASTIDX, smallidx + 8) ;
- minidx = maxidx - 8; /* often this equal smallidx */
- smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2;
- small = magicints[smallidx] / 2;
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ;
- larger = magicints[maxidx];
-
- /* buf[0] holds the length in bytes */
-
- if (xdr_int(xdrs, &(buf[0])) == 0)
- return 0;
- if (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0]) == 0)
- return 0;
- buf[0] = buf[1] = buf[2] = 0;
-
- lfp = fp;
- inv_precision = 1.0 / * precision;
- run = 0;
- i = 0;
- lip = ip;
- while ( i < lsize ) {
- thiscoord = (int *)(lip) + i * 3;
-
- if (bitsize == 0) {
- thiscoord[0] = receivebits(buf, bitsizeint[0]);
- thiscoord[1] = receivebits(buf, bitsizeint[1]);
- thiscoord[2] = receivebits(buf, bitsizeint[2]);
- } else {
- receiveints(buf, 3, bitsize, sizeint, thiscoord);
- }
-
- i++;
- thiscoord[0] += minint[0];
- thiscoord[1] += minint[1];
- thiscoord[2] += minint[2];
-
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
-
-
- flag = receivebits(buf, 1);
- is_smaller = 0;
- if (flag == 1) {
- run = receivebits(buf, 5);
- is_smaller = run % 3;
- run -= is_smaller;
- is_smaller--;
- }
- if (run > 0) {
- thiscoord += 3;
- for (k = 0; k < run; k+=3) {
- receiveints(buf, 3, smallidx, sizesmall, thiscoord);
- i++;
- thiscoord[0] += prevcoord[0] - small;
- thiscoord[1] += prevcoord[1] - small;
- thiscoord[2] += prevcoord[2] - small;
- if (k == 0) {
- /* interchange first with second atom for better
- * compression of water molecules
- */
- tmp = thiscoord[0]; thiscoord[0] = prevcoord[0];
- prevcoord[0] = tmp;
- tmp = thiscoord[1]; thiscoord[1] = prevcoord[1];
- prevcoord[1] = tmp;
- tmp = thiscoord[2]; thiscoord[2] = prevcoord[2];
- prevcoord[2] = tmp;
- *lfp++ = prevcoord[0] * inv_precision;
- *lfp++ = prevcoord[1] * inv_precision;
- *lfp++ = prevcoord[2] * inv_precision;
- } else {
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
- }
- *lfp++ = thiscoord[0] * inv_precision;
- *lfp++ = thiscoord[1] * inv_precision;
- *lfp++ = thiscoord[2] * inv_precision;
- }
- } else {
- *lfp++ = thiscoord[0] * inv_precision;
- *lfp++ = thiscoord[1] * inv_precision;
- *lfp++ = thiscoord[2] * inv_precision;
- }
- smallidx += is_smaller;
- if (is_smaller < 0) {
- small = smaller;
- if (smallidx > FIRSTIDX) {
- smaller = magicints[smallidx - 1] /2;
- } else {
- smaller = 0;
- }
- } else if (is_smaller > 0) {
- smaller = small;
- small = magicints[smallidx] / 2;
- }
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ;
- }
- }
- return 1;
-}
-
-
-
+++ /dev/null
-/*____________________________________________________________________________
- |
- | libxdrf - portable fortran interface to xdr. some xdr routines
- | are C routines for compressed coordinates
- |
- | version 1.1
- |
- | This collection of routines is intended to write and read
- | data in a portable way to a file, so data written on one type
- | of machine can be read back on a different type.
- |
- | all fortran routines use an integer 'xdrid', which is an id to the
- | current xdr file, and is set by xdrfopen.
- | most routines have in integer 'ret' which is the return value.
- | The value of 'ret' is zero on failure, and most of the time one
- | on succes.
- |
- | There are three routines useful for C users:
- | xdropen(), xdrclose(), xdr3dfcoord().
- | The first two replace xdrstdio_create and xdr_destroy, and *must* be
- | used when you plan to use xdr3dfcoord(). (they are also a bit
- | easier to interface). For writing data other than compressed coordinates
- | you should use the standard C xdr routines (see xdr man page)
- |
- | xdrfopen(xdrid, filename, mode, ret)
- | character *(*) filename
- | character *(*) mode
- |
- | this will open the file with the given filename (string)
- | and the given mode, it returns an id in xdrid, which is
- | to be used in all other calls to xdrf routines.
- | mode is 'w' to create, or update an file, for all other
- | values of mode the file is opened for reading
- |
- | you need to call xdrfclose to flush the output and close
- | the file.
- | Note that you should not use xdrstdio_create, which comes with the
- | standard xdr library
- |
- | xdrfclose(xdrid, ret)
- | flush the data to the file, and closes the file;
- | You should not use xdr_destroy (which comes standard with
- | the xdr libraries.
- |
- | xdrfbool(xdrid, bp, ret)
- | integer pb
- |
- | This filter produces values of either 1 or 0
- |
- | xdrfchar(xdrid, cp, ret)
- | character cp
- |
- | filter that translate between characters and their xdr representation
- | Note that the characters in not compressed and occupies 4 bytes.
- |
- | xdrfdouble(xdrid, dp, ret)
- | double dp
- |
- | read/write a double.
- |
- | xdrffloat(xdrid, fp, ret)
- | float fp
- |
- | read/write a float.
- |
- | xdrfint(xdrid, ip, ret)
- | integer ip
- |
- | read/write integer.
- |
- | xdrflong(xdrid, lp, ret)
- | integer lp
- |
- | this routine has a possible portablility problem due to 64 bits longs.
- |
- | xdrfshort(xdrid, sp, ret)
- | integer *2 sp
- |
- | xdrfstring(xdrid, sp, maxsize, ret)
- | character *(*)
- | integer maxsize
- |
- | read/write a string, with maximum length given by maxsize
- |
- | xdrfwrapstring(xdris, sp, ret)
- | character *(*)
- |
- | read/write a string (it is the same as xdrfstring accept that it finds
- | the stringlength itself.
- |
- | xdrfvector(xdrid, cp, size, xdrfproc, ret)
- | character *(*)
- | integer size
- | external xdrfproc
- |
- | read/write an array pointed to by cp, with number of elements
- | defined by 'size'. the routine 'xdrfproc' is the name
- | of one of the above routines to read/write data (like xdrfdouble)
- | In contrast with the c-version you don't need to specify the
- | byte size of an element.
- | xdrfstring is not allowed here (it is in the c version)
- |
- | xdrf3dfcoord(xdrid, fp, size, precision, ret)
- | real (*) fp
- | real precision
- | integer size
- |
- | this is *NOT* a standard xdr routine. I named it this way, because
- | it invites people to use the other xdr routines.
- | It is introduced to store specifically 3d coordinates of molecules
- | (as found in molecular dynamics) and it writes it in a compressed way.
- | It starts by multiplying all numbers by precision and
- | rounding the result to integer. effectively converting
- | all floating point numbers to fixed point.
- | it uses an algorithm for compression that is optimized for
- | molecular data, but could be used for other 3d coordinates
- | as well. There is subtantial overhead involved, so call this
- | routine only if you have a large number of coordinates to read/write
- |
- | ________________________________________________________________________
- |
- | Below are the routines to be used by C programmers. Use the 'normal'
- | xdr routines to write integers, floats, etc (see man xdr)
- |
- | int xdropen(XDR *xdrs, const char *filename, const char *type)
- | This will open the file with the given filename and the
- | given mode. You should pass it an allocated XDR struct
- | in xdrs, to be used in all other calls to xdr routines.
- | Mode is 'w' to create, or update an file, and for all
- | other values of mode the file is opened for reading.
- | You need to call xdrclose to flush the output and close
- | the file.
- |
- | Note that you should not use xdrstdio_create, which
- | comes with the standard xdr library.
- |
- | int xdrclose(XDR *xdrs)
- | Flush the data to the file, and close the file;
- | You should not use xdr_destroy (which comes standard
- | with the xdr libraries).
- |
- | int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision)
- | This is \fInot\fR a standard xdr routine. I named it this
- | way, because it invites people to use the other xdr
- | routines.
- |
- | (c) 1995 Frans van Hoesel, hoesel@chem.rug.nl
-*/
-
-
-#include <limits.h>
-#include <malloc.h>
-#include <math.h>
-#include <rpc/rpc.h>
-#include <rpc/xdr.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include "xdrf.h"
-
-int ftocstr(char *, int, char *, int);
-int ctofstr(char *, int, char *);
-
-#define MAXID 20
-static FILE *xdrfiles[MAXID];
-static XDR *xdridptr[MAXID];
-static char xdrmodes[MAXID];
-static unsigned int cnt;
-
-typedef void (* FUNCTION(xdrfproc)) (int *, void *, int *);
-
-void
-FUNCTION(xdrfbool) ARGS(`xdrid, pb, ret')
-int *xdrid, *ret;
-int *pb;
-{
- *ret = xdr_bool(xdridptr[*xdrid], (bool_t *) pb);
- cnt += sizeof(int);
-}
-
-void
-FUNCTION(xdrfchar) ARGS(`xdrid, cp, ret')
-int *xdrid, *ret;
-char *cp;
-{
- *ret = xdr_char(xdridptr[*xdrid], cp);
- cnt += sizeof(char);
-}
-
-void
-FUNCTION(xdrfdouble) ARGS(`xdrid, dp, ret')
-int *xdrid, *ret;
-double *dp;
-{
- *ret = xdr_double(xdridptr[*xdrid], dp);
- cnt += sizeof(double);
-}
-
-void
-FUNCTION(xdrffloat) ARGS(`xdrid, fp, ret')
-int *xdrid, *ret;
-float *fp;
-{
- *ret = xdr_float(xdridptr[*xdrid], fp);
- cnt += sizeof(float);
-}
-
-void
-FUNCTION(xdrfint) ARGS(`xdrid, ip, ret')
-int *xdrid, *ret;
-int *ip;
-{
- *ret = xdr_int(xdridptr[*xdrid], ip);
- cnt += sizeof(int);
-}
-
-void
-FUNCTION(xdrflong) ARGS(`xdrid, lp, ret')
-int *xdrid, *ret;
-long *lp;
-{
- *ret = xdr_long(xdridptr[*xdrid], lp);
- cnt += sizeof(long);
-}
-
-void
-FUNCTION(xdrfshort) ARGS(`xdrid, sp, ret')
-int *xdrid, *ret;
-short *sp;
-{
- *ret = xdr_short(xdridptr[*xdrid], sp);
- cnt += sizeof(sp);
-}
-
-void
-FUNCTION(xdrfuchar) ARGS(`xdrid, ucp, ret')
-int *xdrid, *ret;
-char *ucp;
-{
- *ret = xdr_u_char(xdridptr[*xdrid], ucp);
- cnt += sizeof(char);
-}
-
-void
-FUNCTION(xdrfulong) ARGS(`xdrid, ulp, ret')
-int *xdrid, *ret;
-unsigned long *ulp;
-{
- *ret = xdr_u_long(xdridptr[*xdrid], ulp);
- cnt += sizeof(unsigned long);
-}
-
-void
-FUNCTION(xdrfushort) ARGS(`xdrid, usp, ret')
-int *xdrid, *ret;
-unsigned short *usp;
-{
- *ret = xdr_u_short(xdridptr[*xdrid], usp);
- cnt += sizeof(unsigned short);
-}
-
-void
-FUNCTION(xdrf3dfcoord) ARGS(`xdrid, fp, size, precision, ret')
-int *xdrid, *ret;
-float *fp;
-int *size;
-float *precision;
-{
- *ret = xdr3dfcoord(xdridptr[*xdrid], fp, size, precision);
-}
-
-void
-FUNCTION(xdrfstring) ARGS(`xdrid, STRING_ARG(sp), maxsize, ret')
-int *xdrid, *ret;
-STRING_ARG_DECL(sp);
-int *maxsize;
-{
- char *tsp;
-
- tsp = (char*) malloc(((STRING_LEN(sp)) + 1) * sizeof(char));
- if (tsp == NULL) {
- *ret = -1;
- return;
- }
- if (ftocstr(tsp, *maxsize+1, STRING_PTR(sp), STRING_LEN(sp))) {
- *ret = -1;
- free(tsp);
- return;
- }
- *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int) *maxsize);
- ctofstr( STRING_PTR(sp), STRING_LEN(sp), tsp);
- cnt += *maxsize;
- free(tsp);
-}
-
-void
-FUNCTION(xdrfwrapstring) ARGS(`xdrid, STRING_ARG(sp), ret')
-int *xdrid, *ret;
-STRING_ARG_DECL(sp);
-{
- char *tsp;
- int maxsize;
- maxsize = (STRING_LEN(sp)) + 1;
- tsp = (char*) malloc(maxsize * sizeof(char));
- if (tsp == NULL) {
- *ret = -1;
- return;
- }
- if (ftocstr(tsp, maxsize, STRING_PTR(sp), STRING_LEN(sp))) {
- *ret = -1;
- free(tsp);
- return;
- }
- *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int)maxsize);
- ctofstr( STRING_PTR(sp), STRING_LEN(sp), tsp);
- cnt += maxsize;
- free(tsp);
-}
-
-void
-FUNCTION(xdrfopaque) ARGS(`xdrid, cp, ccnt, ret')
-int *xdrid, *ret;
-caddr_t *cp;
-int *ccnt;
-{
- *ret = xdr_opaque(xdridptr[*xdrid], (caddr_t)*cp, (u_int)*ccnt);
- cnt += *ccnt;
-}
-
-void
-FUNCTION(xdrfsetpos) ARGS(`xdrid, pos, ret')
-int *xdrid, *ret;
-int *pos;
-{
- *ret = xdr_setpos(xdridptr[*xdrid], (u_int) *pos);
-}
-
-void
-FUNCTION(xdrf) ARGS(`xdrid, pos')
-int *xdrid, *pos;
-{
- *pos = xdr_getpos(xdridptr[*xdrid]);
-}
-
-void
-FUNCTION(xdrfvector) ARGS(`xdrid, cp, size, elproc, ret')
-int *xdrid, *ret;
-char *cp;
-int *size;
-FUNCTION(xdrfproc) elproc;
-{
- int lcnt;
- cnt = 0;
- for (lcnt = 0; lcnt < *size; lcnt++) {
- elproc(xdrid, (cp+cnt) , ret);
- }
-}
-
-
-void
-FUNCTION(xdrfclose) ARGS(`xdrid, ret')
-int *xdrid;
-int *ret;
-{
- *ret = xdrclose(xdridptr[*xdrid]);
- cnt = 0;
-}
-
-void
-FUNCTION(xdrfopen) ARGS(`xdrid, STRING_ARG(fp), STRING_ARG(mode), ret')
-int *xdrid;
-STRING_ARG_DECL(fp);
-STRING_ARG_DECL(mode);
-int *ret;
-{
- char fname[512];
- char fmode[3];
-
- if (ftocstr(fname, sizeof(fname), STRING_PTR(fp), STRING_LEN(fp))) {
- *ret = 0;
- }
- if (ftocstr(fmode, sizeof(fmode), STRING_PTR(mode),
- STRING_LEN(mode))) {
- *ret = 0;
- }
-
- *xdrid = xdropen(NULL, fname, fmode);
- if (*xdrid == 0)
- *ret = 0;
- else
- *ret = 1;
-}
-
-/*___________________________________________________________________________
- |
- | what follows are the C routines for opening, closing xdr streams
- | and the routine to read/write compressed coordinates together
- | with some routines to assist in this task (those are marked
- | static and cannot be called from user programs)
-*/
-#define MAXABS INT_MAX-2
-
-#ifndef MIN
-#define MIN(x,y) ((x) < (y) ? (x):(y))
-#endif
-#ifndef MAX
-#define MAX(x,y) ((x) > (y) ? (x):(y))
-#endif
-#ifndef SQR
-#define SQR(x) ((x)*(x))
-#endif
-static int magicints[] = {
- 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 8, 10, 12, 16, 20, 25, 32, 40, 50, 64,
- 80, 101, 128, 161, 203, 256, 322, 406, 512, 645,
- 812, 1024, 1290, 1625, 2048, 2580, 3250, 4096, 5060, 6501,
- 8192, 10321, 13003, 16384, 20642, 26007, 32768, 41285, 52015, 65536,
- 82570, 104031, 131072, 165140, 208063, 262144, 330280, 416127, 524287, 660561,
- 832255, 1048576, 1321122, 1664510, 2097152, 2642245, 3329021, 4194304, 5284491, 6658042,
- 8388607, 10568983, 13316085, 16777216 };
-
-#define FIRSTIDX 9
-/* note that magicints[FIRSTIDX-1] == 0 */
-#define LASTIDX (sizeof(magicints) / sizeof(*magicints))
-
-
-/*__________________________________________________________________________
- |
- | xdropen - open xdr file
- |
- | This versions differs from xdrstdio_create, because I need to know
- | the state of the file (read or write) so I can use xdr3dfcoord
- | in eigther read or write mode, and the file descriptor
- | so I can close the file (something xdr_destroy doesn't do).
- |
-*/
-
-int xdropen(XDR *xdrs, const char *filename, const char *type) {
- static int init_done = 0;
- enum xdr_op lmode;
- int xdrid;
-
- if (init_done == 0) {
- for (xdrid = 1; xdrid < MAXID; xdrid++) {
- xdridptr[xdrid] = NULL;
- }
- init_done = 1;
- }
- xdrid = 1;
- while (xdrid < MAXID && xdridptr[xdrid] != NULL) {
- xdrid++;
- }
- if (xdrid == MAXID) {
- return 0;
- }
- if (*type == 'w' || *type == 'W') {
- type = "w+";
- lmode = XDR_ENCODE;
- } else {
- type = "r";
- lmode = XDR_DECODE;
- }
- xdrfiles[xdrid] = fopen(filename, type);
- if (xdrfiles[xdrid] == NULL) {
- xdrs = NULL;
- return 0;
- }
- xdrmodes[xdrid] = *type;
- /* next test isn't usefull in the case of C language
- * but is used for the Fortran interface
- * (C users are expected to pass the address of an already allocated
- * XDR staructure)
- */
- if (xdrs == NULL) {
- xdridptr[xdrid] = (XDR *) malloc(sizeof(XDR));
- xdrstdio_create(xdridptr[xdrid], xdrfiles[xdrid], lmode);
- } else {
- xdridptr[xdrid] = xdrs;
- xdrstdio_create(xdrs, xdrfiles[xdrid], lmode);
- }
- return xdrid;
-}
-
-/*_________________________________________________________________________
- |
- | xdrclose - close a xdr file
- |
- | This will flush the xdr buffers, and destroy the xdr stream.
- | It also closes the associated file descriptor (this is *not*
- | done by xdr_destroy).
- |
-*/
-
-int xdrclose(XDR *xdrs) {
- int xdrid;
-
- if (xdrs == NULL) {
- fprintf(stderr, "xdrclose: passed a NULL pointer\n");
- exit(1);
- }
- for (xdrid = 1; xdrid < MAXID; xdrid++) {
- if (xdridptr[xdrid] == xdrs) {
-
- xdr_destroy(xdrs);
- fclose(xdrfiles[xdrid]);
- xdridptr[xdrid] = NULL;
- return 1;
- }
- }
- fprintf(stderr, "xdrclose: no such open xdr file\n");
- exit(1);
-
-}
-
-/*____________________________________________________________________________
- |
- | sendbits - encode num into buf using the specified number of bits
- |
- | This routines appends the value of num to the bits already present in
- | the array buf. You need to give it the number of bits to use and you
- | better make sure that this number of bits is enough to hold the value
- | Also num must be positive.
- |
-*/
-
-static void sendbits(int buf[], int num_of_bits, int num) {
-
- unsigned int cnt, lastbyte;
- int lastbits;
- unsigned char * cbuf;
-
- cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf);
- cnt = (unsigned int) buf[0];
- lastbits = buf[1];
- lastbyte =(unsigned int) buf[2];
- while (num_of_bits >= 8) {
- lastbyte = (lastbyte << 8) | ((num >> (num_of_bits -8)) /* & 0xff*/);
- cbuf[cnt++] = lastbyte >> lastbits;
- num_of_bits -= 8;
- }
- if (num_of_bits > 0) {
- lastbyte = (lastbyte << num_of_bits) | num;
- lastbits += num_of_bits;
- if (lastbits >= 8) {
- lastbits -= 8;
- cbuf[cnt++] = lastbyte >> lastbits;
- }
- }
- buf[0] = cnt;
- buf[1] = lastbits;
- buf[2] = lastbyte;
- if (lastbits>0) {
- cbuf[cnt] = lastbyte << (8 - lastbits);
- }
-}
-
-/*_________________________________________________________________________
- |
- | sizeofint - calculate bitsize of an integer
- |
- | return the number of bits needed to store an integer with given max size
- |
-*/
-
-static int sizeofint(const int size) {
- unsigned int num = 1;
- int num_of_bits = 0;
-
- while (size >= num && num_of_bits < 32) {
- num_of_bits++;
- num <<= 1;
- }
- return num_of_bits;
-}
-
-/*___________________________________________________________________________
- |
- | sizeofints - calculate 'bitsize' of compressed ints
- |
- | given the number of small unsigned integers and the maximum value
- | return the number of bits needed to read or write them with the
- | routines receiveints and sendints. You need this parameter when
- | calling these routines. Note that for many calls I can use
- | the variable 'smallidx' which is exactly the number of bits, and
- | So I don't need to call 'sizeofints for those calls.
-*/
-
-static int sizeofints( const int num_of_ints, unsigned int sizes[]) {
- int i, num;
- unsigned int num_of_bytes, num_of_bits, bytes[32], bytecnt, tmp;
- num_of_bytes = 1;
- bytes[0] = 1;
- num_of_bits = 0;
- for (i=0; i < num_of_ints; i++) {
- tmp = 0;
- for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) {
- tmp = bytes[bytecnt] * sizes[i] + tmp;
- bytes[bytecnt] = tmp & 0xff;
- tmp >>= 8;
- }
- while (tmp != 0) {
- bytes[bytecnt++] = tmp & 0xff;
- tmp >>= 8;
- }
- num_of_bytes = bytecnt;
- }
- num = 1;
- num_of_bytes--;
- while (bytes[num_of_bytes] >= num) {
- num_of_bits++;
- num *= 2;
- }
- return num_of_bits + num_of_bytes * 8;
-
-}
-
-/*____________________________________________________________________________
- |
- | sendints - send a small set of small integers in compressed format
- |
- | this routine is used internally by xdr3dfcoord, to send a set of
- | small integers to the buffer.
- | Multiplication with fixed (specified maximum ) sizes is used to get
- | to one big, multibyte integer. Allthough the routine could be
- | modified to handle sizes bigger than 16777216, or more than just
- | a few integers, this is not done, because the gain in compression
- | isn't worth the effort. Note that overflowing the multiplication
- | or the byte buffer (32 bytes) is unchecked and causes bad results.
- |
- */
-
-static void sendints(int buf[], const int num_of_ints, const int num_of_bits,
- unsigned int sizes[], unsigned int nums[]) {
-
- int i;
- unsigned int bytes[32], num_of_bytes, bytecnt, tmp;
-
- tmp = nums[0];
- num_of_bytes = 0;
- do {
- bytes[num_of_bytes++] = tmp & 0xff;
- tmp >>= 8;
- } while (tmp != 0);
-
- for (i = 1; i < num_of_ints; i++) {
- if (nums[i] >= sizes[i]) {
- fprintf(stderr,"major breakdown in sendints num %d doesn't "
- "match size %d\n", nums[i], sizes[i]);
- exit(1);
- }
- /* use one step multiply */
- tmp = nums[i];
- for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) {
- tmp = bytes[bytecnt] * sizes[i] + tmp;
- bytes[bytecnt] = tmp & 0xff;
- tmp >>= 8;
- }
- while (tmp != 0) {
- bytes[bytecnt++] = tmp & 0xff;
- tmp >>= 8;
- }
- num_of_bytes = bytecnt;
- }
- if (num_of_bits >= num_of_bytes * 8) {
- for (i = 0; i < num_of_bytes; i++) {
- sendbits(buf, 8, bytes[i]);
- }
- sendbits(buf, num_of_bits - num_of_bytes * 8, 0);
- } else {
- for (i = 0; i < num_of_bytes-1; i++) {
- sendbits(buf, 8, bytes[i]);
- }
- sendbits(buf, num_of_bits- (num_of_bytes -1) * 8, bytes[i]);
- }
-}
-
-
-/*___________________________________________________________________________
- |
- | receivebits - decode number from buf using specified number of bits
- |
- | extract the number of bits from the array buf and construct an integer
- | from it. Return that value.
- |
-*/
-
-static int receivebits(int buf[], int num_of_bits) {
-
- int cnt, num;
- unsigned int lastbits, lastbyte;
- unsigned char * cbuf;
- int mask = (1 << num_of_bits) -1;
-
- cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf);
- cnt = buf[0];
- lastbits = (unsigned int) buf[1];
- lastbyte = (unsigned int) buf[2];
-
- num = 0;
- while (num_of_bits >= 8) {
- lastbyte = ( lastbyte << 8 ) | cbuf[cnt++];
- num |= (lastbyte >> lastbits) << (num_of_bits - 8);
- num_of_bits -=8;
- }
- if (num_of_bits > 0) {
- if (lastbits < num_of_bits) {
- lastbits += 8;
- lastbyte = (lastbyte << 8) | cbuf[cnt++];
- }
- lastbits -= num_of_bits;
- num |= (lastbyte >> lastbits) & ((1 << num_of_bits) -1);
- }
- num &= mask;
- buf[0] = cnt;
- buf[1] = lastbits;
- buf[2] = lastbyte;
- return num;
-}
-
-/*____________________________________________________________________________
- |
- | receiveints - decode 'small' integers from the buf array
- |
- | this routine is the inverse from sendints() and decodes the small integers
- | written to buf by calculating the remainder and doing divisions with
- | the given sizes[]. You need to specify the total number of bits to be
- | used from buf in num_of_bits.
- |
-*/
-
-static void receiveints(int buf[], const int num_of_ints, int num_of_bits,
- unsigned int sizes[], int nums[]) {
- int bytes[32];
- int i, j, num_of_bytes, p, num;
-
- bytes[1] = bytes[2] = bytes[3] = 0;
- num_of_bytes = 0;
- while (num_of_bits > 8) {
- bytes[num_of_bytes++] = receivebits(buf, 8);
- num_of_bits -= 8;
- }
- if (num_of_bits > 0) {
- bytes[num_of_bytes++] = receivebits(buf, num_of_bits);
- }
- for (i = num_of_ints-1; i > 0; i--) {
- num = 0;
- for (j = num_of_bytes-1; j >=0; j--) {
- num = (num << 8) | bytes[j];
- p = num / sizes[i];
- bytes[j] = p;
- num = num - p * sizes[i];
- }
- nums[i] = num;
- }
- nums[0] = bytes[0] | (bytes[1] << 8) | (bytes[2] << 16) | (bytes[3] << 24);
-}
-
-/*____________________________________________________________________________
- |
- | xdr3dfcoord - read or write compressed 3d coordinates to xdr file.
- |
- | this routine reads or writes (depending on how you opened the file with
- | xdropen() ) a large number of 3d coordinates (stored in *fp).
- | The number of coordinates triplets to write is given by *size. On
- | read this number may be zero, in which case it reads as many as were written
- | or it may specify the number if triplets to read (which should match the
- | number written).
- | Compression is achieved by first converting all floating numbers to integer
- | using multiplication by *precision and rounding to the nearest integer.
- | Then the minimum and maximum value are calculated to determine the range.
- | The limited range of integers so found, is used to compress the coordinates.
- | In addition the differences between succesive coordinates is calculated.
- | If the difference happens to be 'small' then only the difference is saved,
- | compressing the data even more. The notion of 'small' is changed dynamically
- | and is enlarged or reduced whenever needed or possible.
- | Extra compression is achieved in the case of GROMOS and coordinates of
- | water molecules. GROMOS first writes out the Oxygen position, followed by
- | the two hydrogens. In order to make the differences smaller (and thereby
- | compression the data better) the order is changed into first one hydrogen
- | then the oxygen, followed by the other hydrogen. This is rather special, but
- | it shouldn't harm in the general case.
- |
- */
-
-int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) {
-
-
- static int *ip = NULL;
- static int oldsize;
- static int *buf;
-
- int minint[3], maxint[3], mindiff, *lip, diff;
- int lint1, lint2, lint3, oldlint1, oldlint2, oldlint3, smallidx;
- int minidx, maxidx;
- unsigned sizeint[3], sizesmall[3], bitsizeint[3], size3, *luip;
- int flag, k;
- int small, smaller, larger, i, is_small, is_smaller, run, prevrun;
- float *lfp, lf;
- int tmp, *thiscoord, prevcoord[3];
- unsigned int tmpcoord[30];
-
- int bufsize, xdrid, lsize;
- unsigned int bitsize;
- float inv_precision;
- int errval = 1;
-
- /* find out if xdrs is opened for reading or for writing */
- xdrid = 0;
- while (xdridptr[xdrid] != xdrs) {
- xdrid++;
- if (xdrid >= MAXID) {
- fprintf(stderr, "xdr error. no open xdr stream\n");
- exit (1);
- }
- }
- if (xdrmodes[xdrid] == 'w') {
-
- /* xdrs is open for writing */
-
- if (xdr_int(xdrs, size) == 0)
- return 0;
- size3 = *size * 3;
- /* when the number of coordinates is small, don't try to compress; just
- * write them as floats using xdr_vector
- */
- if (*size <= 9 ) {
- return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp),
- (xdrproc_t)xdr_float));
- }
-
- xdr_float(xdrs, precision);
- if (ip == NULL) {
- ip = (int *)malloc(size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)malloc(bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- } else if (*size > oldsize) {
- ip = (int *)realloc(ip, size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)realloc(buf, bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- }
- /* buf[0-2] are special and do not contain actual data */
- buf[0] = buf[1] = buf[2] = 0;
- minint[0] = minint[1] = minint[2] = INT_MAX;
- maxint[0] = maxint[1] = maxint[2] = INT_MIN;
- prevrun = -1;
- lfp = fp;
- lip = ip;
- mindiff = INT_MAX;
- oldlint1 = oldlint2 = oldlint3 = 0;
- while(lfp < fp + size3 ) {
- /* find nearest integer */
- if (*lfp >= 0.0)
- lf = *lfp * *precision + 0.5;
- else
- lf = *lfp * *precision - 0.5;
- if (fabs(lf) > MAXABS) {
- /* scaling would cause overflow */
- errval = 0;
- }
- lint1 = lf;
- if (lint1 < minint[0]) minint[0] = lint1;
- if (lint1 > maxint[0]) maxint[0] = lint1;
- *lip++ = lint1;
- lfp++;
- if (*lfp >= 0.0)
- lf = *lfp * *precision + 0.5;
- else
- lf = *lfp * *precision - 0.5;
- if (fabs(lf) > MAXABS) {
- /* scaling would cause overflow */
- errval = 0;
- }
- lint2 = lf;
- if (lint2 < minint[1]) minint[1] = lint2;
- if (lint2 > maxint[1]) maxint[1] = lint2;
- *lip++ = lint2;
- lfp++;
- if (*lfp >= 0.0)
- lf = *lfp * *precision + 0.5;
- else
- lf = *lfp * *precision - 0.5;
- if (fabs(lf) > MAXABS) {
- /* scaling would cause overflow */
- errval = 0;
- }
- lint3 = lf;
- if (lint3 < minint[2]) minint[2] = lint3;
- if (lint3 > maxint[2]) maxint[2] = lint3;
- *lip++ = lint3;
- lfp++;
- diff = abs(oldlint1-lint1)+abs(oldlint2-lint2)+abs(oldlint3-lint3);
- if (diff < mindiff && lfp > fp + 3)
- mindiff = diff;
- oldlint1 = lint1;
- oldlint2 = lint2;
- oldlint3 = lint3;
- }
- xdr_int(xdrs, &(minint[0]));
- xdr_int(xdrs, &(minint[1]));
- xdr_int(xdrs, &(minint[2]));
-
- xdr_int(xdrs, &(maxint[0]));
- xdr_int(xdrs, &(maxint[1]));
- xdr_int(xdrs, &(maxint[2]));
-
- if ((float)maxint[0] - (float)minint[0] >= MAXABS ||
- (float)maxint[1] - (float)minint[1] >= MAXABS ||
- (float)maxint[2] - (float)minint[2] >= MAXABS) {
- /* turning value in unsigned by subtracting minint
- * would cause overflow
- */
- errval = 0;
- }
- sizeint[0] = maxint[0] - minint[0]+1;
- sizeint[1] = maxint[1] - minint[1]+1;
- sizeint[2] = maxint[2] - minint[2]+1;
-
- /* check if one of the sizes is to big to be multiplied */
- if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) {
- bitsizeint[0] = sizeofint(sizeint[0]);
- bitsizeint[1] = sizeofint(sizeint[1]);
- bitsizeint[2] = sizeofint(sizeint[2]);
- bitsize = 0; /* flag the use of large sizes */
- } else {
- bitsize = sizeofints(3, sizeint);
- }
- lip = ip;
- luip = (unsigned int *) ip;
- smallidx = FIRSTIDX;
- while (smallidx < LASTIDX && magicints[smallidx] < mindiff) {
- smallidx++;
- }
- xdr_int(xdrs, &smallidx);
- maxidx = MIN(LASTIDX, smallidx + 8) ;
- minidx = maxidx - 8; /* often this equal smallidx */
- smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2;
- small = magicints[smallidx] / 2;
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx];
- larger = magicints[maxidx] / 2;
- i = 0;
- while (i < *size) {
- is_small = 0;
- thiscoord = (int *)(luip) + i * 3;
- if (smallidx < maxidx && i >= 1 &&
- abs(thiscoord[0] - prevcoord[0]) < larger &&
- abs(thiscoord[1] - prevcoord[1]) < larger &&
- abs(thiscoord[2] - prevcoord[2]) < larger) {
- is_smaller = 1;
- } else if (smallidx > minidx) {
- is_smaller = -1;
- } else {
- is_smaller = 0;
- }
- if (i + 1 < *size) {
- if (abs(thiscoord[0] - thiscoord[3]) < small &&
- abs(thiscoord[1] - thiscoord[4]) < small &&
- abs(thiscoord[2] - thiscoord[5]) < small) {
- /* interchange first with second atom for better
- * compression of water molecules
- */
- tmp = thiscoord[0]; thiscoord[0] = thiscoord[3];
- thiscoord[3] = tmp;
- tmp = thiscoord[1]; thiscoord[1] = thiscoord[4];
- thiscoord[4] = tmp;
- tmp = thiscoord[2]; thiscoord[2] = thiscoord[5];
- thiscoord[5] = tmp;
- is_small = 1;
- }
-
- }
- tmpcoord[0] = thiscoord[0] - minint[0];
- tmpcoord[1] = thiscoord[1] - minint[1];
- tmpcoord[2] = thiscoord[2] - minint[2];
- if (bitsize == 0) {
- sendbits(buf, bitsizeint[0], tmpcoord[0]);
- sendbits(buf, bitsizeint[1], tmpcoord[1]);
- sendbits(buf, bitsizeint[2], tmpcoord[2]);
- } else {
- sendints(buf, 3, bitsize, sizeint, tmpcoord);
- }
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
- thiscoord = thiscoord + 3;
- i++;
-
- run = 0;
- if (is_small == 0 && is_smaller == -1)
- is_smaller = 0;
- while (is_small && run < 8*3) {
- if (is_smaller == -1 && (
- SQR(thiscoord[0] - prevcoord[0]) +
- SQR(thiscoord[1] - prevcoord[1]) +
- SQR(thiscoord[2] - prevcoord[2]) >= smaller * smaller)) {
- is_smaller = 0;
- }
-
- tmpcoord[run++] = thiscoord[0] - prevcoord[0] + small;
- tmpcoord[run++] = thiscoord[1] - prevcoord[1] + small;
- tmpcoord[run++] = thiscoord[2] - prevcoord[2] + small;
-
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
-
- i++;
- thiscoord = thiscoord + 3;
- is_small = 0;
- if (i < *size &&
- abs(thiscoord[0] - prevcoord[0]) < small &&
- abs(thiscoord[1] - prevcoord[1]) < small &&
- abs(thiscoord[2] - prevcoord[2]) < small) {
- is_small = 1;
- }
- }
- if (run != prevrun || is_smaller != 0) {
- prevrun = run;
- sendbits(buf, 1, 1); /* flag the change in run-length */
- sendbits(buf, 5, run+is_smaller+1);
- } else {
- sendbits(buf, 1, 0); /* flag the fact that runlength did not change */
- }
- for (k=0; k < run; k+=3) {
- sendints(buf, 3, smallidx, sizesmall, &tmpcoord[k]);
- }
- if (is_smaller != 0) {
- smallidx += is_smaller;
- if (is_smaller < 0) {
- small = smaller;
- smaller = magicints[smallidx-1] / 2;
- } else {
- smaller = small;
- small = magicints[smallidx] / 2;
- }
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx];
- }
- }
- if (buf[1] != 0) buf[0]++;;
- xdr_int(xdrs, &(buf[0])); /* buf[0] holds the length in bytes */
- return errval * (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0]));
- } else {
-
- /* xdrs is open for reading */
-
- if (xdr_int(xdrs, &lsize) == 0)
- return 0;
- if (*size != 0 && lsize != *size) {
- fprintf(stderr, "wrong number of coordinates in xdr3dfcoor; "
- "%d arg vs %d in file", *size, lsize);
- }
- *size = lsize;
- size3 = *size * 3;
- if (*size <= 9) {
- return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp),
- (xdrproc_t)xdr_float));
- }
- xdr_float(xdrs, precision);
- if (ip == NULL) {
- ip = (int *)malloc(size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)malloc(bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- } else if (*size > oldsize) {
- ip = (int *)realloc(ip, size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)realloc(buf, bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- }
- buf[0] = buf[1] = buf[2] = 0;
-
- xdr_int(xdrs, &(minint[0]));
- xdr_int(xdrs, &(minint[1]));
- xdr_int(xdrs, &(minint[2]));
-
- xdr_int(xdrs, &(maxint[0]));
- xdr_int(xdrs, &(maxint[1]));
- xdr_int(xdrs, &(maxint[2]));
-
- sizeint[0] = maxint[0] - minint[0]+1;
- sizeint[1] = maxint[1] - minint[1]+1;
- sizeint[2] = maxint[2] - minint[2]+1;
-
- /* check if one of the sizes is to big to be multiplied */
- if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) {
- bitsizeint[0] = sizeofint(sizeint[0]);
- bitsizeint[1] = sizeofint(sizeint[1]);
- bitsizeint[2] = sizeofint(sizeint[2]);
- bitsize = 0; /* flag the use of large sizes */
- } else {
- bitsize = sizeofints(3, sizeint);
- }
-
- xdr_int(xdrs, &smallidx);
- maxidx = MIN(LASTIDX, smallidx + 8) ;
- minidx = maxidx - 8; /* often this equal smallidx */
- smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2;
- small = magicints[smallidx] / 2;
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ;
- larger = magicints[maxidx];
-
- /* buf[0] holds the length in bytes */
-
- if (xdr_int(xdrs, &(buf[0])) == 0)
- return 0;
- if (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0]) == 0)
- return 0;
- buf[0] = buf[1] = buf[2] = 0;
-
- lfp = fp;
- inv_precision = 1.0 / * precision;
- run = 0;
- i = 0;
- lip = ip;
- while ( i < lsize ) {
- thiscoord = (int *)(lip) + i * 3;
-
- if (bitsize == 0) {
- thiscoord[0] = receivebits(buf, bitsizeint[0]);
- thiscoord[1] = receivebits(buf, bitsizeint[1]);
- thiscoord[2] = receivebits(buf, bitsizeint[2]);
- } else {
- receiveints(buf, 3, bitsize, sizeint, thiscoord);
- }
-
- i++;
- thiscoord[0] += minint[0];
- thiscoord[1] += minint[1];
- thiscoord[2] += minint[2];
-
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
-
-
- flag = receivebits(buf, 1);
- is_smaller = 0;
- if (flag == 1) {
- run = receivebits(buf, 5);
- is_smaller = run % 3;
- run -= is_smaller;
- is_smaller--;
- }
- if (run > 0) {
- thiscoord += 3;
- for (k = 0; k < run; k+=3) {
- receiveints(buf, 3, smallidx, sizesmall, thiscoord);
- i++;
- thiscoord[0] += prevcoord[0] - small;
- thiscoord[1] += prevcoord[1] - small;
- thiscoord[2] += prevcoord[2] - small;
- if (k == 0) {
- /* interchange first with second atom for better
- * compression of water molecules
- */
- tmp = thiscoord[0]; thiscoord[0] = prevcoord[0];
- prevcoord[0] = tmp;
- tmp = thiscoord[1]; thiscoord[1] = prevcoord[1];
- prevcoord[1] = tmp;
- tmp = thiscoord[2]; thiscoord[2] = prevcoord[2];
- prevcoord[2] = tmp;
- *lfp++ = prevcoord[0] * inv_precision;
- *lfp++ = prevcoord[1] * inv_precision;
- *lfp++ = prevcoord[2] * inv_precision;
- } else {
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
- }
- *lfp++ = thiscoord[0] * inv_precision;
- *lfp++ = thiscoord[1] * inv_precision;
- *lfp++ = thiscoord[2] * inv_precision;
- }
- } else {
- *lfp++ = thiscoord[0] * inv_precision;
- *lfp++ = thiscoord[1] * inv_precision;
- *lfp++ = thiscoord[2] * inv_precision;
- }
- smallidx += is_smaller;
- if (is_smaller < 0) {
- small = smaller;
- if (smallidx > FIRSTIDX) {
- smaller = magicints[smallidx - 1] /2;
- } else {
- smaller = 0;
- }
- } else if (is_smaller > 0) {
- smaller = small;
- small = magicints[smallidx] / 2;
- }
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ;
- }
- }
- return 1;
-}
-
-
-
+++ /dev/null
-/*____________________________________________________________________________
- |
- | libxdrf - portable fortran interface to xdr. some xdr routines
- | are C routines for compressed coordinates
- |
- | version 1.1
- |
- | This collection of routines is intended to write and read
- | data in a portable way to a file, so data written on one type
- | of machine can be read back on a different type.
- |
- | all fortran routines use an integer 'xdrid', which is an id to the
- | current xdr file, and is set by xdrfopen.
- | most routines have in integer 'ret' which is the return value.
- | The value of 'ret' is zero on failure, and most of the time one
- | on succes.
- |
- | There are three routines useful for C users:
- | xdropen(), xdrclose(), xdr3dfcoord().
- | The first two replace xdrstdio_create and xdr_destroy, and *must* be
- | used when you plan to use xdr3dfcoord(). (they are also a bit
- | easier to interface). For writing data other than compressed coordinates
- | you should use the standard C xdr routines (see xdr man page)
- |
- | xdrfopen(xdrid, filename, mode, ret)
- | character *(*) filename
- | character *(*) mode
- |
- | this will open the file with the given filename (string)
- | and the given mode, it returns an id in xdrid, which is
- | to be used in all other calls to xdrf routines.
- | mode is 'w' to create, or update an file, for all other
- | values of mode the file is opened for reading
- |
- | you need to call xdrfclose to flush the output and close
- | the file.
- | Note that you should not use xdrstdio_create, which comes with the
- | standard xdr library
- |
- | xdrfclose(xdrid, ret)
- | flush the data to the file, and closes the file;
- | You should not use xdr_destroy (which comes standard with
- | the xdr libraries.
- |
- | xdrfbool(xdrid, bp, ret)
- | integer pb
- |
- | This filter produces values of either 1 or 0
- |
- | xdrfchar(xdrid, cp, ret)
- | character cp
- |
- | filter that translate between characters and their xdr representation
- | Note that the characters in not compressed and occupies 4 bytes.
- |
- | xdrfdouble(xdrid, dp, ret)
- | double dp
- |
- | read/write a double.
- |
- | xdrffloat(xdrid, fp, ret)
- | float fp
- |
- | read/write a float.
- |
- | xdrfint(xdrid, ip, ret)
- | integer ip
- |
- | read/write integer.
- |
- | xdrflong(xdrid, lp, ret)
- | integer lp
- |
- | this routine has a possible portablility problem due to 64 bits longs.
- |
- | xdrfshort(xdrid, sp, ret)
- | integer *2 sp
- |
- | xdrfstring(xdrid, sp, maxsize, ret)
- | character *(*)
- | integer maxsize
- |
- | read/write a string, with maximum length given by maxsize
- |
- | xdrfwrapstring(xdris, sp, ret)
- | character *(*)
- |
- | read/write a string (it is the same as xdrfstring accept that it finds
- | the stringlength itself.
- |
- | xdrfvector(xdrid, cp, size, xdrfproc, ret)
- | character *(*)
- | integer size
- | external xdrfproc
- |
- | read/write an array pointed to by cp, with number of elements
- | defined by 'size'. the routine 'xdrfproc' is the name
- | of one of the above routines to read/write data (like xdrfdouble)
- | In contrast with the c-version you don't need to specify the
- | byte size of an element.
- | xdrfstring is not allowed here (it is in the c version)
- |
- | xdrf3dfcoord(xdrid, fp, size, precision, ret)
- | real (*) fp
- | real precision
- | integer size
- |
- | this is *NOT* a standard xdr routine. I named it this way, because
- | it invites people to use the other xdr routines.
- | It is introduced to store specifically 3d coordinates of molecules
- | (as found in molecular dynamics) and it writes it in a compressed way.
- | It starts by multiplying all numbers by precision and
- | rounding the result to integer. effectively converting
- | all floating point numbers to fixed point.
- | it uses an algorithm for compression that is optimized for
- | molecular data, but could be used for other 3d coordinates
- | as well. There is subtantial overhead involved, so call this
- | routine only if you have a large number of coordinates to read/write
- |
- | ________________________________________________________________________
- |
- | Below are the routines to be used by C programmers. Use the 'normal'
- | xdr routines to write integers, floats, etc (see man xdr)
- |
- | int xdropen(XDR *xdrs, const char *filename, const char *type)
- | This will open the file with the given filename and the
- | given mode. You should pass it an allocated XDR struct
- | in xdrs, to be used in all other calls to xdr routines.
- | Mode is 'w' to create, or update an file, and for all
- | other values of mode the file is opened for reading.
- | You need to call xdrclose to flush the output and close
- | the file.
- |
- | Note that you should not use xdrstdio_create, which
- | comes with the standard xdr library.
- |
- | int xdrclose(XDR *xdrs)
- | Flush the data to the file, and close the file;
- | You should not use xdr_destroy (which comes standard
- | with the xdr libraries).
- |
- | int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision)
- | This is \fInot\fR a standard xdr routine. I named it this
- | way, because it invites people to use the other xdr
- | routines.
- |
- | (c) 1995 Frans van Hoesel, hoesel@chem.rug.nl
-*/
-
-
-#include <limits.h>
-#include <malloc.h>
-#include <math.h>
-#include <rpc/rpc.h>
-#include <rpc/xdr.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include "xdrf.h"
-
-int ftocstr(char *, int, char *, int);
-int ctofstr(char *, int, char *);
-
-#define MAXID 20
-static FILE *xdrfiles[MAXID];
-static XDR *xdridptr[MAXID];
-static char xdrmodes[MAXID];
-static unsigned int cnt;
-
-typedef void (* FUNCTION(xdrfproc)) (int *, void *, int *);
-
-void
-FUNCTION(xdrfbool) ARGS(`xdrid, pb, ret')
-int *xdrid, *ret;
-int *pb;
-{
- *ret = xdr_bool(xdridptr[*xdrid], (bool_t *) pb);
- cnt += sizeof(int);
-}
-
-void
-FUNCTION(xdrfchar) ARGS(`xdrid, cp, ret')
-int *xdrid, *ret;
-char *cp;
-{
- *ret = xdr_char(xdridptr[*xdrid], cp);
- cnt += sizeof(char);
-}
-
-void
-FUNCTION(xdrfdouble) ARGS(`xdrid, dp, ret')
-int *xdrid, *ret;
-double *dp;
-{
- *ret = xdr_double(xdridptr[*xdrid], dp);
- cnt += sizeof(double);
-}
-
-void
-FUNCTION(xdrffloat) ARGS(`xdrid, fp, ret')
-int *xdrid, *ret;
-float *fp;
-{
- *ret = xdr_float(xdridptr[*xdrid], fp);
- cnt += sizeof(float);
-}
-
-void
-FUNCTION(xdrfint) ARGS(`xdrid, ip, ret')
-int *xdrid, *ret;
-int *ip;
-{
- *ret = xdr_int(xdridptr[*xdrid], ip);
- cnt += sizeof(int);
-}
-
-void
-FUNCTION(xdrflong) ARGS(`xdrid, lp, ret')
-int *xdrid, *ret;
-long *lp;
-{
- *ret = xdr_long(xdridptr[*xdrid], lp);
- cnt += sizeof(long);
-}
-
-void
-FUNCTION(xdrfshort) ARGS(`xdrid, sp, ret')
-int *xdrid, *ret;
-short *sp;
-{
- *ret = xdr_short(xdridptr[*xdrid], sp);
- cnt += sizeof(sp);
-}
-
-void
-FUNCTION(xdrfuchar) ARGS(`xdrid, ucp, ret')
-int *xdrid, *ret;
-char *ucp;
-{
- *ret = xdr_u_char(xdridptr[*xdrid], ucp);
- cnt += sizeof(char);
-}
-
-void
-FUNCTION(xdrfulong) ARGS(`xdrid, ulp, ret')
-int *xdrid, *ret;
-unsigned long *ulp;
-{
- *ret = xdr_u_long(xdridptr[*xdrid], ulp);
- cnt += sizeof(unsigned long);
-}
-
-void
-FUNCTION(xdrfushort) ARGS(`xdrid, usp, ret')
-int *xdrid, *ret;
-unsigned short *usp;
-{
- *ret = xdr_u_short(xdridptr[*xdrid], usp);
- cnt += sizeof(unsigned short);
-}
-
-void
-FUNCTION(xdrf3dfcoord) ARGS(`xdrid, fp, size, precision, ret')
-int *xdrid, *ret;
-float *fp;
-int *size;
-float *precision;
-{
- *ret = xdr3dfcoord(xdridptr[*xdrid], fp, size, precision);
-}
-
-void
-FUNCTION(xdrfstring) ARGS(`xdrid, STRING_ARG(sp), maxsize, ret')
-int *xdrid, *ret;
-STRING_ARG_DECL(sp);
-int *maxsize;
-{
- char *tsp;
-
- tsp = (char*) malloc(((STRING_LEN(sp)) + 1) * sizeof(char));
- if (tsp == NULL) {
- *ret = -1;
- return;
- }
- if (ftocstr(tsp, *maxsize+1, STRING_PTR(sp), STRING_LEN(sp))) {
- *ret = -1;
- free(tsp);
- return;
- }
- *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int) *maxsize);
- ctofstr( STRING_PTR(sp), STRING_LEN(sp), tsp);
- cnt += *maxsize;
- free(tsp);
-}
-
-void
-FUNCTION(xdrfwrapstring) ARGS(`xdrid, STRING_ARG(sp), ret')
-int *xdrid, *ret;
-STRING_ARG_DECL(sp);
-{
- char *tsp;
- int maxsize;
- maxsize = (STRING_LEN(sp)) + 1;
- tsp = (char*) malloc(maxsize * sizeof(char));
- if (tsp == NULL) {
- *ret = -1;
- return;
- }
- if (ftocstr(tsp, maxsize, STRING_PTR(sp), STRING_LEN(sp))) {
- *ret = -1;
- free(tsp);
- return;
- }
- *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int)maxsize);
- ctofstr( STRING_PTR(sp), STRING_LEN(sp), tsp);
- cnt += maxsize;
- free(tsp);
-}
-
-void
-FUNCTION(xdrfopaque) ARGS(`xdrid, cp, ccnt, ret')
-int *xdrid, *ret;
-caddr_t *cp;
-int *ccnt;
-{
- *ret = xdr_opaque(xdridptr[*xdrid], (caddr_t)*cp, (u_int)*ccnt);
- cnt += *ccnt;
-}
-
-void
-FUNCTION(xdrfsetpos) ARGS(`xdrid, pos, ret')
-int *xdrid, *ret;
-int *pos;
-{
- *ret = xdr_setpos(xdridptr[*xdrid], (u_int) *pos);
-}
-
-void
-FUNCTION(xdrf) ARGS(`xdrid, pos')
-int *xdrid, *pos;
-{
- *pos = xdr_getpos(xdridptr[*xdrid]);
-}
-
-void
-FUNCTION(xdrfvector) ARGS(`xdrid, cp, size, elproc, ret')
-int *xdrid, *ret;
-char *cp;
-int *size;
-FUNCTION(xdrfproc) elproc;
-{
- int lcnt;
- cnt = 0;
- for (lcnt = 0; lcnt < *size; lcnt++) {
- elproc(xdrid, (cp+cnt) , ret);
- }
-}
-
-
-void
-FUNCTION(xdrfclose) ARGS(`xdrid, ret')
-int *xdrid;
-int *ret;
-{
- *ret = xdrclose(xdridptr[*xdrid]);
- cnt = 0;
-}
-
-void
-FUNCTION(xdrfopen) ARGS(`xdrid, STRING_ARG(fp), STRING_ARG(mode), ret')
-int *xdrid;
-STRING_ARG_DECL(fp);
-STRING_ARG_DECL(mode);
-int *ret;
-{
- char fname[512];
- char fmode[3];
-
- if (ftocstr(fname, sizeof(fname), STRING_PTR(fp), STRING_LEN(fp))) {
- *ret = 0;
- }
- if (ftocstr(fmode, sizeof(fmode), STRING_PTR(mode),
- STRING_LEN(mode))) {
- *ret = 0;
- }
-
- *xdrid = xdropen(NULL, fname, fmode);
- if (*xdrid == 0)
- *ret = 0;
- else
- *ret = 1;
-}
-
-/*___________________________________________________________________________
- |
- | what follows are the C routines for opening, closing xdr streams
- | and the routine to read/write compressed coordinates together
- | with some routines to assist in this task (those are marked
- | static and cannot be called from user programs)
-*/
-#define MAXABS INT_MAX-2
-
-#ifndef MIN
-#define MIN(x,y) ((x) < (y) ? (x):(y))
-#endif
-#ifndef MAX
-#define MAX(x,y) ((x) > (y) ? (x):(y))
-#endif
-#ifndef SQR
-#define SQR(x) ((x)*(x))
-#endif
-static int magicints[] = {
- 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 8, 10, 12, 16, 20, 25, 32, 40, 50, 64,
- 80, 101, 128, 161, 203, 256, 322, 406, 512, 645,
- 812, 1024, 1290, 1625, 2048, 2580, 3250, 4096, 5060, 6501,
- 8192, 10321, 13003, 16384, 20642, 26007, 32768, 41285, 52015, 65536,
- 82570, 104031, 131072, 165140, 208063, 262144, 330280, 416127, 524287, 660561,
- 832255, 1048576, 1321122, 1664510, 2097152, 2642245, 3329021, 4194304, 5284491, 6658042,
- 8388607, 10568983, 13316085, 16777216 };
-
-#define FIRSTIDX 9
-/* note that magicints[FIRSTIDX-1] == 0 */
-#define LASTIDX (sizeof(magicints) / sizeof(*magicints))
-
-
-/*__________________________________________________________________________
- |
- | xdropen - open xdr file
- |
- | This versions differs from xdrstdio_create, because I need to know
- | the state of the file (read or write) so I can use xdr3dfcoord
- | in eigther read or write mode, and the file descriptor
- | so I can close the file (something xdr_destroy doesn't do).
- |
-*/
-
-int xdropen(XDR *xdrs, const char *filename, const char *type) {
- static int init_done = 0;
- enum xdr_op lmode;
- const char *type1;
- int xdrid;
-
- if (init_done == 0) {
- for (xdrid = 1; xdrid < MAXID; xdrid++) {
- xdridptr[xdrid] = NULL;
- }
- init_done = 1;
- }
- xdrid = 1;
- while (xdrid < MAXID && xdridptr[xdrid] != NULL) {
- xdrid++;
- }
- if (xdrid == MAXID) {
- return 0;
- }
- if (*type == 'w' || *type == 'W') {
- type = "w+";
- type1 = "a+";
- lmode = XDR_ENCODE;
- } else {
- type = "r";
- lmode = XDR_DECODE;
- }
- xdrfiles[xdrid] = fopen(filename, type1);
- if (xdrfiles[xdrid] == NULL) {
- xdrs = NULL;
- return 0;
- }
- xdrmodes[xdrid] = *type;
- /* next test isn't usefull in the case of C language
- * but is used for the Fortran interface
- * (C users are expected to pass the address of an already allocated
- * XDR staructure)
- */
- if (xdrs == NULL) {
- xdridptr[xdrid] = (XDR *) malloc(sizeof(XDR));
- xdrstdio_create(xdridptr[xdrid], xdrfiles[xdrid], lmode);
- } else {
- xdridptr[xdrid] = xdrs;
- xdrstdio_create(xdrs, xdrfiles[xdrid], lmode);
- }
- return xdrid;
-}
-
-/*_________________________________________________________________________
- |
- | xdrclose - close a xdr file
- |
- | This will flush the xdr buffers, and destroy the xdr stream.
- | It also closes the associated file descriptor (this is *not*
- | done by xdr_destroy).
- |
-*/
-
-int xdrclose(XDR *xdrs) {
- int xdrid;
-
- if (xdrs == NULL) {
- fprintf(stderr, "xdrclose: passed a NULL pointer\n");
- exit(1);
- }
- for (xdrid = 1; xdrid < MAXID; xdrid++) {
- if (xdridptr[xdrid] == xdrs) {
-
- xdr_destroy(xdrs);
- fclose(xdrfiles[xdrid]);
- xdridptr[xdrid] = NULL;
- return 1;
- }
- }
- fprintf(stderr, "xdrclose: no such open xdr file\n");
- exit(1);
-
-}
-
-/*____________________________________________________________________________
- |
- | sendbits - encode num into buf using the specified number of bits
- |
- | This routines appends the value of num to the bits already present in
- | the array buf. You need to give it the number of bits to use and you
- | better make sure that this number of bits is enough to hold the value
- | Also num must be positive.
- |
-*/
-
-static void sendbits(int buf[], int num_of_bits, int num) {
-
- unsigned int cnt, lastbyte;
- int lastbits;
- unsigned char * cbuf;
-
- cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf);
- cnt = (unsigned int) buf[0];
- lastbits = buf[1];
- lastbyte =(unsigned int) buf[2];
- while (num_of_bits >= 8) {
- lastbyte = (lastbyte << 8) | ((num >> (num_of_bits -8)) /* & 0xff*/);
- cbuf[cnt++] = lastbyte >> lastbits;
- num_of_bits -= 8;
- }
- if (num_of_bits > 0) {
- lastbyte = (lastbyte << num_of_bits) | num;
- lastbits += num_of_bits;
- if (lastbits >= 8) {
- lastbits -= 8;
- cbuf[cnt++] = lastbyte >> lastbits;
- }
- }
- buf[0] = cnt;
- buf[1] = lastbits;
- buf[2] = lastbyte;
- if (lastbits>0) {
- cbuf[cnt] = lastbyte << (8 - lastbits);
- }
-}
-
-/*_________________________________________________________________________
- |
- | sizeofint - calculate bitsize of an integer
- |
- | return the number of bits needed to store an integer with given max size
- |
-*/
-
-static int sizeofint(const int size) {
- unsigned int num = 1;
- int num_of_bits = 0;
-
- while (size >= num && num_of_bits < 32) {
- num_of_bits++;
- num <<= 1;
- }
- return num_of_bits;
-}
-
-/*___________________________________________________________________________
- |
- | sizeofints - calculate 'bitsize' of compressed ints
- |
- | given the number of small unsigned integers and the maximum value
- | return the number of bits needed to read or write them with the
- | routines receiveints and sendints. You need this parameter when
- | calling these routines. Note that for many calls I can use
- | the variable 'smallidx' which is exactly the number of bits, and
- | So I don't need to call 'sizeofints for those calls.
-*/
-
-static int sizeofints( const int num_of_ints, unsigned int sizes[]) {
- int i, num;
- unsigned int num_of_bytes, num_of_bits, bytes[32], bytecnt, tmp;
- num_of_bytes = 1;
- bytes[0] = 1;
- num_of_bits = 0;
- for (i=0; i < num_of_ints; i++) {
- tmp = 0;
- for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) {
- tmp = bytes[bytecnt] * sizes[i] + tmp;
- bytes[bytecnt] = tmp & 0xff;
- tmp >>= 8;
- }
- while (tmp != 0) {
- bytes[bytecnt++] = tmp & 0xff;
- tmp >>= 8;
- }
- num_of_bytes = bytecnt;
- }
- num = 1;
- num_of_bytes--;
- while (bytes[num_of_bytes] >= num) {
- num_of_bits++;
- num *= 2;
- }
- return num_of_bits + num_of_bytes * 8;
-
-}
-
-/*____________________________________________________________________________
- |
- | sendints - send a small set of small integers in compressed format
- |
- | this routine is used internally by xdr3dfcoord, to send a set of
- | small integers to the buffer.
- | Multiplication with fixed (specified maximum ) sizes is used to get
- | to one big, multibyte integer. Allthough the routine could be
- | modified to handle sizes bigger than 16777216, or more than just
- | a few integers, this is not done, because the gain in compression
- | isn't worth the effort. Note that overflowing the multiplication
- | or the byte buffer (32 bytes) is unchecked and causes bad results.
- |
- */
-
-static void sendints(int buf[], const int num_of_ints, const int num_of_bits,
- unsigned int sizes[], unsigned int nums[]) {
-
- int i;
- unsigned int bytes[32], num_of_bytes, bytecnt, tmp;
-
- tmp = nums[0];
- num_of_bytes = 0;
- do {
- bytes[num_of_bytes++] = tmp & 0xff;
- tmp >>= 8;
- } while (tmp != 0);
-
- for (i = 1; i < num_of_ints; i++) {
- if (nums[i] >= sizes[i]) {
- fprintf(stderr,"major breakdown in sendints num %d doesn't "
- "match size %d\n", nums[i], sizes[i]);
- exit(1);
- }
- /* use one step multiply */
- tmp = nums[i];
- for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) {
- tmp = bytes[bytecnt] * sizes[i] + tmp;
- bytes[bytecnt] = tmp & 0xff;
- tmp >>= 8;
- }
- while (tmp != 0) {
- bytes[bytecnt++] = tmp & 0xff;
- tmp >>= 8;
- }
- num_of_bytes = bytecnt;
- }
- if (num_of_bits >= num_of_bytes * 8) {
- for (i = 0; i < num_of_bytes; i++) {
- sendbits(buf, 8, bytes[i]);
- }
- sendbits(buf, num_of_bits - num_of_bytes * 8, 0);
- } else {
- for (i = 0; i < num_of_bytes-1; i++) {
- sendbits(buf, 8, bytes[i]);
- }
- sendbits(buf, num_of_bits- (num_of_bytes -1) * 8, bytes[i]);
- }
-}
-
-
-/*___________________________________________________________________________
- |
- | receivebits - decode number from buf using specified number of bits
- |
- | extract the number of bits from the array buf and construct an integer
- | from it. Return that value.
- |
-*/
-
-static int receivebits(int buf[], int num_of_bits) {
-
- int cnt, num;
- unsigned int lastbits, lastbyte;
- unsigned char * cbuf;
- int mask = (1 << num_of_bits) -1;
-
- cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf);
- cnt = buf[0];
- lastbits = (unsigned int) buf[1];
- lastbyte = (unsigned int) buf[2];
-
- num = 0;
- while (num_of_bits >= 8) {
- lastbyte = ( lastbyte << 8 ) | cbuf[cnt++];
- num |= (lastbyte >> lastbits) << (num_of_bits - 8);
- num_of_bits -=8;
- }
- if (num_of_bits > 0) {
- if (lastbits < num_of_bits) {
- lastbits += 8;
- lastbyte = (lastbyte << 8) | cbuf[cnt++];
- }
- lastbits -= num_of_bits;
- num |= (lastbyte >> lastbits) & ((1 << num_of_bits) -1);
- }
- num &= mask;
- buf[0] = cnt;
- buf[1] = lastbits;
- buf[2] = lastbyte;
- return num;
-}
-
-/*____________________________________________________________________________
- |
- | receiveints - decode 'small' integers from the buf array
- |
- | this routine is the inverse from sendints() and decodes the small integers
- | written to buf by calculating the remainder and doing divisions with
- | the given sizes[]. You need to specify the total number of bits to be
- | used from buf in num_of_bits.
- |
-*/
-
-static void receiveints(int buf[], const int num_of_ints, int num_of_bits,
- unsigned int sizes[], int nums[]) {
- int bytes[32];
- int i, j, num_of_bytes, p, num;
-
- bytes[1] = bytes[2] = bytes[3] = 0;
- num_of_bytes = 0;
- while (num_of_bits > 8) {
- bytes[num_of_bytes++] = receivebits(buf, 8);
- num_of_bits -= 8;
- }
- if (num_of_bits > 0) {
- bytes[num_of_bytes++] = receivebits(buf, num_of_bits);
- }
- for (i = num_of_ints-1; i > 0; i--) {
- num = 0;
- for (j = num_of_bytes-1; j >=0; j--) {
- num = (num << 8) | bytes[j];
- p = num / sizes[i];
- bytes[j] = p;
- num = num - p * sizes[i];
- }
- nums[i] = num;
- }
- nums[0] = bytes[0] | (bytes[1] << 8) | (bytes[2] << 16) | (bytes[3] << 24);
-}
-
-/*____________________________________________________________________________
- |
- | xdr3dfcoord - read or write compressed 3d coordinates to xdr file.
- |
- | this routine reads or writes (depending on how you opened the file with
- | xdropen() ) a large number of 3d coordinates (stored in *fp).
- | The number of coordinates triplets to write is given by *size. On
- | read this number may be zero, in which case it reads as many as were written
- | or it may specify the number if triplets to read (which should match the
- | number written).
- | Compression is achieved by first converting all floating numbers to integer
- | using multiplication by *precision and rounding to the nearest integer.
- | Then the minimum and maximum value are calculated to determine the range.
- | The limited range of integers so found, is used to compress the coordinates.
- | In addition the differences between succesive coordinates is calculated.
- | If the difference happens to be 'small' then only the difference is saved,
- | compressing the data even more. The notion of 'small' is changed dynamically
- | and is enlarged or reduced whenever needed or possible.
- | Extra compression is achieved in the case of GROMOS and coordinates of
- | water molecules. GROMOS first writes out the Oxygen position, followed by
- | the two hydrogens. In order to make the differences smaller (and thereby
- | compression the data better) the order is changed into first one hydrogen
- | then the oxygen, followed by the other hydrogen. This is rather special, but
- | it shouldn't harm in the general case.
- |
- */
-
-int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) {
-
-
- static int *ip = NULL;
- static int oldsize;
- static int *buf;
-
- int minint[3], maxint[3], mindiff, *lip, diff;
- int lint1, lint2, lint3, oldlint1, oldlint2, oldlint3, smallidx;
- int minidx, maxidx;
- unsigned sizeint[3], sizesmall[3], bitsizeint[3], size3, *luip;
- int flag, k;
- int small, smaller, larger, i, is_small, is_smaller, run, prevrun;
- float *lfp, lf;
- int tmp, *thiscoord, prevcoord[3];
- unsigned int tmpcoord[30];
-
- int bufsize, xdrid, lsize;
- unsigned int bitsize;
- float inv_precision;
- int errval = 1;
-
- /* find out if xdrs is opened for reading or for writing */
- xdrid = 0;
- while (xdridptr[xdrid] != xdrs) {
- xdrid++;
- if (xdrid >= MAXID) {
- fprintf(stderr, "xdr error. no open xdr stream\n");
- exit (1);
- }
- }
- if (xdrmodes[xdrid] == 'w') {
-
- /* xdrs is open for writing */
-
- if (xdr_int(xdrs, size) == 0)
- return 0;
- size3 = *size * 3;
- /* when the number of coordinates is small, don't try to compress; just
- * write them as floats using xdr_vector
- */
- if (*size <= 9 ) {
- return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp),
- (xdrproc_t)xdr_float));
- }
-
- xdr_float(xdrs, precision);
- if (ip == NULL) {
- ip = (int *)malloc(size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)malloc(bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- } else if (*size > oldsize) {
- ip = (int *)realloc(ip, size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)realloc(buf, bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- }
- /* buf[0-2] are special and do not contain actual data */
- buf[0] = buf[1] = buf[2] = 0;
- minint[0] = minint[1] = minint[2] = INT_MAX;
- maxint[0] = maxint[1] = maxint[2] = INT_MIN;
- prevrun = -1;
- lfp = fp;
- lip = ip;
- mindiff = INT_MAX;
- oldlint1 = oldlint2 = oldlint3 = 0;
- while(lfp < fp + size3 ) {
- /* find nearest integer */
- if (*lfp >= 0.0)
- lf = *lfp * *precision + 0.5;
- else
- lf = *lfp * *precision - 0.5;
- if (fabs(lf) > MAXABS) {
- /* scaling would cause overflow */
- errval = 0;
- }
- lint1 = lf;
- if (lint1 < minint[0]) minint[0] = lint1;
- if (lint1 > maxint[0]) maxint[0] = lint1;
- *lip++ = lint1;
- lfp++;
- if (*lfp >= 0.0)
- lf = *lfp * *precision + 0.5;
- else
- lf = *lfp * *precision - 0.5;
- if (fabs(lf) > MAXABS) {
- /* scaling would cause overflow */
- errval = 0;
- }
- lint2 = lf;
- if (lint2 < minint[1]) minint[1] = lint2;
- if (lint2 > maxint[1]) maxint[1] = lint2;
- *lip++ = lint2;
- lfp++;
- if (*lfp >= 0.0)
- lf = *lfp * *precision + 0.5;
- else
- lf = *lfp * *precision - 0.5;
- if (fabs(lf) > MAXABS) {
- /* scaling would cause overflow */
- errval = 0;
- }
- lint3 = lf;
- if (lint3 < minint[2]) minint[2] = lint3;
- if (lint3 > maxint[2]) maxint[2] = lint3;
- *lip++ = lint3;
- lfp++;
- diff = abs(oldlint1-lint1)+abs(oldlint2-lint2)+abs(oldlint3-lint3);
- if (diff < mindiff && lfp > fp + 3)
- mindiff = diff;
- oldlint1 = lint1;
- oldlint2 = lint2;
- oldlint3 = lint3;
- }
- xdr_int(xdrs, &(minint[0]));
- xdr_int(xdrs, &(minint[1]));
- xdr_int(xdrs, &(minint[2]));
-
- xdr_int(xdrs, &(maxint[0]));
- xdr_int(xdrs, &(maxint[1]));
- xdr_int(xdrs, &(maxint[2]));
-
- if ((float)maxint[0] - (float)minint[0] >= MAXABS ||
- (float)maxint[1] - (float)minint[1] >= MAXABS ||
- (float)maxint[2] - (float)minint[2] >= MAXABS) {
- /* turning value in unsigned by subtracting minint
- * would cause overflow
- */
- errval = 0;
- }
- sizeint[0] = maxint[0] - minint[0]+1;
- sizeint[1] = maxint[1] - minint[1]+1;
- sizeint[2] = maxint[2] - minint[2]+1;
-
- /* check if one of the sizes is to big to be multiplied */
- if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) {
- bitsizeint[0] = sizeofint(sizeint[0]);
- bitsizeint[1] = sizeofint(sizeint[1]);
- bitsizeint[2] = sizeofint(sizeint[2]);
- bitsize = 0; /* flag the use of large sizes */
- } else {
- bitsize = sizeofints(3, sizeint);
- }
- lip = ip;
- luip = (unsigned int *) ip;
- smallidx = FIRSTIDX;
- while (smallidx < LASTIDX && magicints[smallidx] < mindiff) {
- smallidx++;
- }
- xdr_int(xdrs, &smallidx);
- maxidx = MIN(LASTIDX, smallidx + 8) ;
- minidx = maxidx - 8; /* often this equal smallidx */
- smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2;
- small = magicints[smallidx] / 2;
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx];
- larger = magicints[maxidx] / 2;
- i = 0;
- while (i < *size) {
- is_small = 0;
- thiscoord = (int *)(luip) + i * 3;
- if (smallidx < maxidx && i >= 1 &&
- abs(thiscoord[0] - prevcoord[0]) < larger &&
- abs(thiscoord[1] - prevcoord[1]) < larger &&
- abs(thiscoord[2] - prevcoord[2]) < larger) {
- is_smaller = 1;
- } else if (smallidx > minidx) {
- is_smaller = -1;
- } else {
- is_smaller = 0;
- }
- if (i + 1 < *size) {
- if (abs(thiscoord[0] - thiscoord[3]) < small &&
- abs(thiscoord[1] - thiscoord[4]) < small &&
- abs(thiscoord[2] - thiscoord[5]) < small) {
- /* interchange first with second atom for better
- * compression of water molecules
- */
- tmp = thiscoord[0]; thiscoord[0] = thiscoord[3];
- thiscoord[3] = tmp;
- tmp = thiscoord[1]; thiscoord[1] = thiscoord[4];
- thiscoord[4] = tmp;
- tmp = thiscoord[2]; thiscoord[2] = thiscoord[5];
- thiscoord[5] = tmp;
- is_small = 1;
- }
-
- }
- tmpcoord[0] = thiscoord[0] - minint[0];
- tmpcoord[1] = thiscoord[1] - minint[1];
- tmpcoord[2] = thiscoord[2] - minint[2];
- if (bitsize == 0) {
- sendbits(buf, bitsizeint[0], tmpcoord[0]);
- sendbits(buf, bitsizeint[1], tmpcoord[1]);
- sendbits(buf, bitsizeint[2], tmpcoord[2]);
- } else {
- sendints(buf, 3, bitsize, sizeint, tmpcoord);
- }
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
- thiscoord = thiscoord + 3;
- i++;
-
- run = 0;
- if (is_small == 0 && is_smaller == -1)
- is_smaller = 0;
- while (is_small && run < 8*3) {
- if (is_smaller == -1 && (
- SQR(thiscoord[0] - prevcoord[0]) +
- SQR(thiscoord[1] - prevcoord[1]) +
- SQR(thiscoord[2] - prevcoord[2]) >= smaller * smaller)) {
- is_smaller = 0;
- }
-
- tmpcoord[run++] = thiscoord[0] - prevcoord[0] + small;
- tmpcoord[run++] = thiscoord[1] - prevcoord[1] + small;
- tmpcoord[run++] = thiscoord[2] - prevcoord[2] + small;
-
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
-
- i++;
- thiscoord = thiscoord + 3;
- is_small = 0;
- if (i < *size &&
- abs(thiscoord[0] - prevcoord[0]) < small &&
- abs(thiscoord[1] - prevcoord[1]) < small &&
- abs(thiscoord[2] - prevcoord[2]) < small) {
- is_small = 1;
- }
- }
- if (run != prevrun || is_smaller != 0) {
- prevrun = run;
- sendbits(buf, 1, 1); /* flag the change in run-length */
- sendbits(buf, 5, run+is_smaller+1);
- } else {
- sendbits(buf, 1, 0); /* flag the fact that runlength did not change */
- }
- for (k=0; k < run; k+=3) {
- sendints(buf, 3, smallidx, sizesmall, &tmpcoord[k]);
- }
- if (is_smaller != 0) {
- smallidx += is_smaller;
- if (is_smaller < 0) {
- small = smaller;
- smaller = magicints[smallidx-1] / 2;
- } else {
- smaller = small;
- small = magicints[smallidx] / 2;
- }
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx];
- }
- }
- if (buf[1] != 0) buf[0]++;;
- xdr_int(xdrs, &(buf[0])); /* buf[0] holds the length in bytes */
- return errval * (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0]));
- } else {
-
- /* xdrs is open for reading */
-
- if (xdr_int(xdrs, &lsize) == 0)
- return 0;
- if (*size != 0 && lsize != *size) {
- fprintf(stderr, "wrong number of coordinates in xdr3dfcoor; "
- "%d arg vs %d in file", *size, lsize);
- }
- *size = lsize;
- size3 = *size * 3;
- if (*size <= 9) {
- return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp),
- (xdrproc_t)xdr_float));
- }
- xdr_float(xdrs, precision);
- if (ip == NULL) {
- ip = (int *)malloc(size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)malloc(bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- } else if (*size > oldsize) {
- ip = (int *)realloc(ip, size3 * sizeof(*ip));
- if (ip == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- bufsize = size3 * 1.2;
- buf = (int *)realloc(buf, bufsize * sizeof(*buf));
- if (buf == NULL) {
- fprintf(stderr,"malloc failed\n");
- exit(1);
- }
- oldsize = *size;
- }
- buf[0] = buf[1] = buf[2] = 0;
-
- xdr_int(xdrs, &(minint[0]));
- xdr_int(xdrs, &(minint[1]));
- xdr_int(xdrs, &(minint[2]));
-
- xdr_int(xdrs, &(maxint[0]));
- xdr_int(xdrs, &(maxint[1]));
- xdr_int(xdrs, &(maxint[2]));
-
- sizeint[0] = maxint[0] - minint[0]+1;
- sizeint[1] = maxint[1] - minint[1]+1;
- sizeint[2] = maxint[2] - minint[2]+1;
-
- /* check if one of the sizes is to big to be multiplied */
- if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) {
- bitsizeint[0] = sizeofint(sizeint[0]);
- bitsizeint[1] = sizeofint(sizeint[1]);
- bitsizeint[2] = sizeofint(sizeint[2]);
- bitsize = 0; /* flag the use of large sizes */
- } else {
- bitsize = sizeofints(3, sizeint);
- }
-
- xdr_int(xdrs, &smallidx);
- maxidx = MIN(LASTIDX, smallidx + 8) ;
- minidx = maxidx - 8; /* often this equal smallidx */
- smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2;
- small = magicints[smallidx] / 2;
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ;
- larger = magicints[maxidx];
-
- /* buf[0] holds the length in bytes */
-
- if (xdr_int(xdrs, &(buf[0])) == 0)
- return 0;
- if (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0]) == 0)
- return 0;
- buf[0] = buf[1] = buf[2] = 0;
-
- lfp = fp;
- inv_precision = 1.0 / * precision;
- run = 0;
- i = 0;
- lip = ip;
- while ( i < lsize ) {
- thiscoord = (int *)(lip) + i * 3;
-
- if (bitsize == 0) {
- thiscoord[0] = receivebits(buf, bitsizeint[0]);
- thiscoord[1] = receivebits(buf, bitsizeint[1]);
- thiscoord[2] = receivebits(buf, bitsizeint[2]);
- } else {
- receiveints(buf, 3, bitsize, sizeint, thiscoord);
- }
-
- i++;
- thiscoord[0] += minint[0];
- thiscoord[1] += minint[1];
- thiscoord[2] += minint[2];
-
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
-
-
- flag = receivebits(buf, 1);
- is_smaller = 0;
- if (flag == 1) {
- run = receivebits(buf, 5);
- is_smaller = run % 3;
- run -= is_smaller;
- is_smaller--;
- }
- if (run > 0) {
- thiscoord += 3;
- for (k = 0; k < run; k+=3) {
- receiveints(buf, 3, smallidx, sizesmall, thiscoord);
- i++;
- thiscoord[0] += prevcoord[0] - small;
- thiscoord[1] += prevcoord[1] - small;
- thiscoord[2] += prevcoord[2] - small;
- if (k == 0) {
- /* interchange first with second atom for better
- * compression of water molecules
- */
- tmp = thiscoord[0]; thiscoord[0] = prevcoord[0];
- prevcoord[0] = tmp;
- tmp = thiscoord[1]; thiscoord[1] = prevcoord[1];
- prevcoord[1] = tmp;
- tmp = thiscoord[2]; thiscoord[2] = prevcoord[2];
- prevcoord[2] = tmp;
- *lfp++ = prevcoord[0] * inv_precision;
- *lfp++ = prevcoord[1] * inv_precision;
- *lfp++ = prevcoord[2] * inv_precision;
- } else {
- prevcoord[0] = thiscoord[0];
- prevcoord[1] = thiscoord[1];
- prevcoord[2] = thiscoord[2];
- }
- *lfp++ = thiscoord[0] * inv_precision;
- *lfp++ = thiscoord[1] * inv_precision;
- *lfp++ = thiscoord[2] * inv_precision;
- }
- } else {
- *lfp++ = thiscoord[0] * inv_precision;
- *lfp++ = thiscoord[1] * inv_precision;
- *lfp++ = thiscoord[2] * inv_precision;
- }
- smallidx += is_smaller;
- if (is_smaller < 0) {
- small = smaller;
- if (smallidx > FIRSTIDX) {
- smaller = magicints[smallidx - 1] /2;
- } else {
- smaller = 0;
- }
- } else if (is_smaller > 0) {
- smaller = small;
- small = magicints[smallidx] / 2;
- }
- sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ;
- }
- }
- return 1;
-}
-
-
-
+++ /dev/null
-divert(-1)
-undefine(`len')
-#
-# append an underscore to FORTRAN function names
-#
-define(`FUNCTION',`$1_')
-#
-# FORTRAN character strings are passed as follows:
-# a pointer to the base of the string is passed in the normal
-# argument list, and the length is passed by value as an extra
-# argument, after all of the other arguments.
-#
-define(`ARGS',`($1`'undivert(1))')
-define(`SAVE',`divert(1)$1`'divert(0)')
-define(`STRING_ARG',`$1_ptr`'SAVE(`, $1_len')')
-define(`STRING_ARG_DECL',`char * $1_ptr; int $1_len')
-define(`STRING_LEN',`$1_len')
-define(`STRING_PTR',`$1_ptr')
-divert(0)
+++ /dev/null
-/*_________________________________________________________________
- |
- | xdrf.h - include file for C routines that want to use the
- | functions below.
-*/
-
-int xdropen(XDR *xdrs, const char *filename, const char *type);
-int xdrclose(XDR *xdrs) ;
-int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) ;
-
projects / unres.git / commitdiff