|
OpenMCTDHB v2.3
|
|
OpenMCTDHB v2.3
|
00001 ! vim:fdm=marker: 00002 !------------------------------------------------------------------------------ 00010 MODULE modulederivesystemvariables 00011 IMPLICIT NONE 00012 REAL*8,SAVE :: weight 00013 00014 00015 00016 CONTAINS 00017 00018 !------------------------------------------------------------------------------ 00029 SUBROUTINE get_weight(xi,xf,yi,yf,zi,zf,NDX,NDY,NDZ,Dims,weight) 00030 !---{{{ 00031 IMPLICIT NONE 00032 REAL*8,INTENT(IN) :: xi,xf,yi,yf,zi,zf 00033 INTEGER,INTENT(IN) :: NDX,NDY,NDZ,Dims 00034 00035 REAL*8,INTENT(OUT) :: weight 00036 REAL*8 :: dx,dy,dz,TOL 00037 00038 TOL = 1.0D-6 00039 weight = 0.0d0 00040 dx = 0.0d0 00041 dy = 0.0d0 00042 dz = 0.0d0 00043 00044 IF (Dims == 1) THEN 00045 00046 dx = (xf-xi)/NDX 00047 IF (dx > TOL ) THEN 00048 weight = DSQRT(dx) 00049 ELSE 00050 WRITE(*,*)"dx = ",dx 00051 WRITE(*,*)"THERE IS PROBABLY SOMETHING WRONG WITH YOUR GRID. TO CONTINUE ANYWAY HIT ENTER" 00052 READ(*,*) 00053 END IF 00054 00055 ELSE IF (Dims == 2) THEN 00056 00057 dx = (xf-xi)/NDX 00058 dy = (yf-yi)/NDY 00059 IF (dx > TOL .AND. dy > TOL ) THEN 00060 weight = DSQRT(dx*dy) 00061 ELSE 00062 WRITE(*,*)"dx = ",dx 00063 WRITE(*,*)"dy = ",dy 00064 WRITE(*,*)"THERE IS PROBABLY SOMETHING WRONG WITH YOUR GRID. TO CONTINUE ANYWAY HIT ENTER" 00065 READ(*,*) 00066 END IF 00067 00068 ELSE IF (Dims == 3) THEN 00069 00070 dx = (xf-xi)/NDX 00071 dy = (yf-yi)/NDY 00072 dz = (zf-zi)/NDZ 00073 IF (dx > TOL .AND. dy > TOL .AND. dz > TOL) THEN 00074 weight = DSQRT(dx*dy*dz) 00075 ELSE 00076 WRITE(*,*)"dx = ",dx 00077 WRITE(*,*)"dy = ",dy 00078 WRITE(*,*)"dz = ",dz 00079 WRITE(*,*)"THERE IS PROBABLY SOMETHING WRONG WITH YOUR GRID. TO CONTINUE ANYWAY HIT ENTER" 00080 READ(*,*) 00081 END IF 00082 00083 ELSE 00084 00085 WRITE(*,*)"INVALID NUMBER OF DIMENSIONS Dims = ",Dims 00086 STOP 00087 00088 END IF 00089 00090 IF (DABS(weight) < 1.0D-10 ) THEN 00091 00092 WRITE(*,*)"THERE IS PROBABLY SOMETHING WRONG WITH YOUR GRID, weight",weight 00093 00094 END IF 00095 00096 !---}}} 00097 END SUBROUTINE get_weight 00098 00099 !------------------------------------------------------------------------------------------- 00110 SUBROUTINE get_nConf(NPar,MOrb,nConf) 00111 !---{{{ IMPLICIT NONE 00112 INTEGER, INTENT(IN) :: NPar,MOrb 00113 INTEGER, INTENT(OUT) :: nConf 00114 real*8 :: realval 00115 00116 realval=binomial(NPar+MOrb-1,NPar) 00117 nConf=NINT(realval) 00118 00119 00120 IF (DABS(realval-nConf)>0.05d0) THEN 00121 00122 write(*,*)"" 00123 write(*,*)"WATCH OUT, THE BETA FUNCTION BECOMES IMPRECISE!" 00124 write(*,*)"real nConf ", realval 00125 write(*,*)"and NINT(nConf)", nConf 00126 write(*,*)"" 00127 read(*,*) 00128 00129 END IF 00130 00131 !---}}} 00132 END SUBROUTINE get_nConf 00133 00134 !----------------------------------------------------------------------------- 00144 SUBROUTINE get_nSuperDiags(NPar,MOrb,nSuperDiags) 00145 !---{{{ 00146 IMPLICIT NONE 00147 00148 INTEGER, INTENT(IN) :: NPar,MOrb 00149 INTEGER, INTENT(OUT) :: nSuperDiags 00150 00151 00152 IF(MOrb .LT. 1) THEN 00153 WRITE(*,*)"INVALID VALUE FOR M",MOrb 00154 STOP 00155 ENDIF 00156 00157 IF(MOrb == 1) nSuperDiags = 0 00158 IF(MOrb == 2) nSuperDiags = 2 00159 IF(MOrb > 2) THEN 00160 WRITE(*,*)"SORRY, M<=2 IS NECESSARY FOR USING ZHBMV EFFICIENTLY" 00161 STOP 00162 ENDIF 00163 00164 IF(NPar==1) THEN 00165 00166 IF(MOrb==1) THEN 00167 nSuperDiags = 0 00168 ELSE 00169 WRITE(*,*)"PLEASE SET M=1 FOR NPAR=1" 00170 STOP 00171 ENDIF 00172 00173 ENDIF 00174 !---}}} 00175 END SUBROUTINE get_nSuperDiags 00176 00177 !------------------------------------------------------------------------------ 00182 SUBROUTINE get_totalNoGridPts(NDX,NDY,NDZ,Dims,totalNoGridPts) 00183 !---{{{ 00184 IMPLICIT NONE 00185 INTEGER, INTENT(IN) :: NDX,NDY,NDZ,Dims 00186 INTEGER, INTENT(OUT) :: totalNoGridPts 00187 00188 totalNoGridPts=NDX*NDY*NDZ 00189 00190 IF (totalNoGridPts <= 0) THEN 00191 WRITE(*,*)"you messed up, total number of grid points:",totalNoGridPts 00192 STOP 00193 END IF 00194 00195 IF (Dims==1 .AND. totalNoGridPts /= NDX) THEN 00196 WRITE(*,*) "INCONSISTENT GRID AND DIMENSION" 00197 STOP 00198 END IF 00199 00200 IF (Dims==2 .AND. totalNoGridPts /= NDX*NDY) THEN 00201 WRITE(*,*) "INCONSISTENT GRID AND DIMENSION" 00202 STOP 00203 END IF 00204 00205 IF (Dims==3 .AND. totalNoGridPts /= NDX*NDY*NDZ) THEN 00206 WRITE(*,*) "INCONSISTENT GRID AND DIMENSION" 00207 STOP 00208 END IF 00209 00210 00211 !---}}} 00212 END SUBROUTINE get_totalNoGridPts 00213 00214 !------------------------------------------------------------------------------ 00224 REAL*8 FUNCTION binomial(n,k) 00225 !---{{{ 00226 IMPLICIT NONE 00227 real*8 :: beta 00228 integer,intent(in) :: N,K 00229 00230 binomial= 1.d0/beta(DBLE(N-K+1),DBLE(K+1)) * 1.d0/(N+1) 00231 !---}}} 00232 end function binomial 00233 00234 00235 00236 00237 END MODULE modulederivesystemvariables
1.7.3
